File Coverage

blib/lib/Object/Meta/Plugin/Host.pm

Criterion	Covered	Total	%
statement	134	156	85.9
branch	28	44	63.6
condition	16	32	50.0
subroutine	31	35	88.5
pod	9	10	90.0
total	218	277	78.7

#!/usr/bin/perl
# $Id: Host.pm,v 1.12 2003/11/29 14:35:24 nothingmuch Exp $

package Object::Meta::Plugin::Host;

use strict;
use warnings;

use autouse Carp => qw(croak);
use Tie::RefHash;

our $VERSION = 0.01;
our $AUTOLOAD;

sub new {
	my $pkg = shift;
	my $self = {
		plugins => {}, # plugin ref hash
		methods => {}, # method look up, with an array of plugin refs per method
	};

	tie %{ $self->{plugins} }, 'Tie::RefHash';

	bless $self, $pkg;
}

sub self { # used when we're not plugged
	return $_[0];
}

sub plugins {
	my $self = shift->self; # in case we're plugged
	return $self->{plugins};
}

sub methods {
	my $self = shift->self; # in case we're plugged
	return $self->{methods};
}

sub plug {
	my $self = shift->self; # in case we're plugged
	my $plugin = shift;

	croak "Doesn't look like a plugin" if (grep { not $plugin->can($_) } qw/init/);

	return $self->register($plugin->init(@_) or croak "init() did not return an export list");
}

sub unplug { #
	my $self = shift->self; # in case we're plugged

	foreach my $plugin (@_){
		foreach my $method (keys %{ $self->methods }){
			next unless $plugin->can($method);
			@{ $self->methods->{$method} } = grep { $_ != $plugin } @{ $self->methods->{$method} };
			delete $self->methods->{$method} unless @{ $self->methods->{$method} };
		}

		delete $self->plugins->{$plugin};
	}
	# munge the stack
}

sub register { # export list
	my $self = shift->self; # in case we're plugged
	my $x = shift;

	# create the stack

	croak "That doesn't look like a valid export list" if (!$x or grep { not $x->can($_) } qw/list plugin exists merge unmerge/);

	foreach my $method ($x->list()){
		croak "Method $method is reserved for use by the context object" if Object::Meta::Plugin::Host::Context->UNIVERSAL::can($method);
		croak "Can't locate object method \"$method\" via package  \"", (ref $x->plugin()), "\"" unless $x->plugin->can($method);

		my $stack = $self->stack($method) || [];

		push @{$stack}, $x->plugin();

		$self->stack($method, $stack);
	}

	exists $self->plugins->{$x->plugin} ? $self->plugins->{$x->plugin}->merge($x) : $self->plugins->{$x->plugin} = $x; # should return success
}

sub unregister {
	my $self = shift->self;

	foreach my $x (@_){
		croak "That doesn't look like a valid export list" if (!$x or grep { not $x->can($_) } qw/list plugin/);

		$self->plugins->{$x->plugin}->unmerge($x);

		if ($x->list()){
			foreach my $method ($x->list()){
				next unless $self->stack($method);

				@{ $self->stack($method) } = grep { $_ != $x->plugin } @{ $self->stack($method) };

				delete $self->methods->{$method} unless (@{ $self->stack($method) });
			}
		} else {
			$self->unplug($x->plugin());
		}
	}
}

sub stack { # : lvalue { # grant access to the stack of a certain method.
	my $self = shift->self; # in case we're plugged
	my $method = shift;

	@_ ? ($self->methods->{$method} = shift) : $self->methods->{$method};
}

sub can { # provide a subref you can goto
	my $self = shift->self; # in case we're plugged
	my $method = shift;
	return $self->UNIVERSAL::can($method) || ($self->stack($method) && sub { $AUTOLOAD = "::" . $method; goto &AUTOLOAD }) || undef;
}

sub AUTOLOAD { # where the magic happens
	my $super = shift;
	my $self = $super->self; # in case we're plugged

	$AUTOLOAD =~ /.*::(.*?)$/;
	my $method = $1;
	croak "Method $method is reserved for use by the context object" if Object::Meta::Plugin::Host::Context->UNIVERSAL::can($method);

	return undef if $method eq 'DESTROY';
	my $stack = $self->stack($method) or croak "Can't locate object method \"$method\" via any plugin in $self";
	Object::Meta::Plugin::Host::Context->new($super, ${ $stack }[ $#$stack ])->$method(@_); # __PACKAGE__::Context ?
}

package Object::Meta::Plugin::Host::Context; # the wrapper object which defines the context of a plugin

use strict;
use warnings;

use autouse Carp => qw(croak);

our $VERSION = 0.01;
our $AUTOLOAD;

sub new {
	my $pkg = shift;

	my $self = bless {
		host => shift,
		plugin => shift,
		instance => shift || 0, # a plugin can be plugged into several slots, each of which needs it's own context
	}, $pkg;

	$self;
}

sub offset { # get a context with a numerical offset
	my $self = shift;
	my $offset = shift;

	Object::Meta::Plugin::Host::Context::Offset->new($self->host,$self->plugin,$offset,$self->{instance});
}

sub prev { # an overlying method - call a context one above
	my $self = shift;
	$self->offset(1);
}

sub next { # an underlying method - call a context one below
	my $self = shift;
	$self->offset(-1);
}

sub super { # the real self: Object::Meta::Plugin::Host
	my $self = shift;
	$self->{host};
}
sub host { goto &super }

sub plugin {
	my $self = shift;
	$self->{plugin};
}
sub self { goto &plugin }

sub can { # try to return the correct method.
	my $self = shift;
	my $method = shift;
	$self->UNIVERSAL::can($method) || $self->plugin->can($method) || $self->host->can($method); # it's one of these, in that order
}

sub AUTOLOAD {
	my $self = shift;

	$AUTOLOAD =~ /.*::(.*?)$/;
	my $method = $1;
	return undef if $method eq 'DESTROY';

	if (${ $self->super->self->plugins }{$self->plugin}->exists($method)){ # examine the plugin's export list in the host
		### stray from magic - this is as worse as it should get
		unshift @_, $self; # return self to the argument list. Should be O(1). lets hope.
		goto &{ $self->plugin->can($method) or croak ($self->plugin . " can't $method") };
	} else {
		$self->host->$method(@_);
	}
}

package Object::Meta::Plugin::Host::Context::Offset; # used to implement next and previous.

use strict;
use warnings;
use autouse Carp => qw(croak);

our $AUTOLOAD;

sub new {
	my $pkg = shift;

	my $self = bless {
		host => shift,
		plugin => shift,
		offset => shift,
		instance => shift || 0,
	}, $pkg;

	$self;
}

sub can { $AUTOLOAD = ref $_[0] . "::can"; goto &AUTOLOAD; }; # $$$ not yet tested. I'm pretty sure AUTOLOAD will [not][ be hit after UNIVERSAL::can is found. It doesn't rally matter.
sub AUTOLOAD { # it has to be less ugly than this
	my $self = shift;
	$AUTOLOAD =~ /.*::(.*?)$/;
	my $method = $1;
	return undef if $method eq 'DESTROY';

	my $stack = $self->{host}->self->stack($method) || croak "Can't locate object method \"$method\" via any plugin in ${ $self }{host}";

	my %counts;

	my $i;
	my $j = $self->{instance};

	for ($i = $#$stack; $i >= 0 or croak "The plugin which requested an offset is not in the stack for the method $method which it called"; $i--){
		${ $stack }[$i] == $self->{plugin} and (-1 == --$j) and last;
		$counts{ ${ $stack }[$i] }++;
	}

	my $x = $i;
	$i += $self->{offset};
	for (; $x >= $i; $x--){
		$counts{ ${ $stack }[$x] }++;
	}

	croak "The offset is out of the range of the method stack for $method\n" if ($i > $#$stack or $i < 0);

	Object::Meta::Plugin::Host::Context->new($self->{host}, ${ $stack }[$i], $counts{${ $stack }[$i]} -1  )->$method(@_);
}

1; # Keep your mother happy.

__END__