File Coverage

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

Criterion	Covered	Total	%
statement	112	204	54.9
branch	17	54	31.4
condition	7	30	23.3
subroutine	28	55	50.9
pod	8	10	80.0
total	172	353	48.7

#!/usr/bin/perl
# $Id: Host.pm,v 1.23 2003/12/11 14:27:17 nothingmuch Exp $

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

use strict;
use warnings;

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

our $VERSION = 0.02;
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 plugins {
	my $self = shift;
	return $self->{plugins};
}

sub methods {
	my $self = shift;

	return $self->{methods};
}

sub plug {
	my $self = shift;
	my $plugin = shift;

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

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

	if ($x->info->style() eq 'implicit'){

		if (reftype($plugin) eq 'ARRAY'){
			warnings::warnif($plugin,"You probably shouldn't use implicit access context shims if the underlying plugin's structure is already a tied array. Use the 'tied' style if you want to suppress this message") if do { local $@; eval { tied (@{$plugin}) } };
		} else {
			warnings::warnif($plugin,"Overloading a plugin's \@{} operator will create unexpected behavior under the implicit style") if (overload::Method($plugin, '@{}'));
		}
	} else {
		STYLE: {
			foreach my $style (@Object::Meta::Plugin::Host::Context::styles){
				last STYLE if ($x->info->style() eq $style)
			}

			croak "Unknown plugin style \"",$x->info->style(),"\" for $plugin";
		}
	}

	$x;
}

sub unplug { #
	my $self = shift;

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

sub register { # export list
	my $self = shift;
	my $x = shift;

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

	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 plugin ", $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;

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

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

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

sub stack { # : lvalue { # grant access to the stack of a certain method.
	my $self = shift;
	my $method = shift;

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

sub specific {
	my $self = shift;
	my $plugin = shift;

	croak "$plugin is not plugged into $self" unless exists $self->plugins->{$plugin};

	Object::Meta::Plugin::Host::Context->new($self, $plugin);
}

sub can { # provide a subref you can goto
	my $self = shift;
	my $method = shift;
	return $self->UNIVERSAL::can($method)
		|| ($self->stack($method) && sub { $AUTOLOAD = $method; goto &AUTOLOAD })
		|| ($self->UNIVERSAL::can('super') && $self->super->can($method));
}

sub AUTOLOAD { # where the magic happens
	my $self = shift;

	$AUTOLOAD =~ /([^:]*?)$/;
	my $method = $1;

	croak "Method \"$method\" is reserved for use by the context object" if Object::Meta::Plugin::Host::Context->UNIVERSAL::can($method); # UNIVERSAL can differs

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

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

use strict;
use warnings;

use autouse 'Scalar::Util' => qw(reftype);
use autouse Carp => qw(croak);

our $VERSION = 0.01;
our $AUTOLOAD;

our @styles = qw/implicit explicit force-implicit/;

sub new {
	my $pkg = shift;

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

	my $style = $self->host->plugins->{$self->plugin}->info->style();

	return $self if $style eq 'explicit';

	reftype($self->plugin) eq 'ARRAY' and do {
		my @array;
		tie @array, __PACKAGE__."::TiedSelf", $self;
		$self = \@array;
	};

	bless $self, __PACKAGE__."::Overloaded";
}

### these methods access internals
### they need the real value of $self

sub instance {
	my $self = shift;
	$self = tied(@$self) || $self;
	$self->[2];
}

sub super { # the real host
	my $self = shift;
	$self = tied(@$self) || $self;
	$self->[0];
}
sub host { goto &super }

sub plugin {
	my $self = shift;
	$self = tied(@$self) || $self;
	$self->[1];
}
sub self { goto &plugin }

### methods from here on don't access internals

sub offset { # get a context with a numerical offset
	my $self = shift;
	my $offset = -1 * 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 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 (my $code = $self->plugin->can($method)){ # examine the plugin's export list in the host
		unshift @_, $self; # return self to the argument list. Should be O(1). lets hope.
		goto &$code;
	} else {
		$self->host->$method(@_);
	}
}

package Object::Meta::Plugin::Host::Context::Overloaded;
use base 'Object::Meta::Plugin::Host::Context';
use overload map { $_, 'plugin' } ('${}', '%{}', '&{}', '*{}', '=', 'nomethod'), fallback => 0;  # all ref types except for arrays, aswell as any other value are simply delegated to the plugin's overloading (if at all). No magic autogeneration is to be performed.

package Object::Meta::Plugin::Host::Context::TiedSelf;
use base 'Object::Meta::Plugin::Host::Context';

#use base 'Tie::Array'; # don't bother wasting the time. tie for arrays is thought to be stable. We'll be overriding anyway for efficiency reasons.

sub TIEARRAY { bless $_[1], $_[0] };
sub FETCH { $_[0]->plugin->[$_[1]] };
sub STORE { $_[0]->plugin->[$_[1]] = $_[2] };
sub FETCHSIZE { scalar @{$_[0]->plugin} };
sub STORESIZE { $#{$_[0]->plugin} = $_[1]-1 };
sub EXTEND { $#{$_[0]->plugin} += $_[1] };
sub EXSISTS { exists $_[0]->plugin->[$_[1]] };
sub DELETE { delete $_[0]->plugin->[$_[1]] };
sub CLEAR { @{$_[0]->plugin} = () };
sub PUSH { push @{$_[0]->plugin}, $_[1] };
sub POP { pop @{$_[0]->plugin} };
sub SHIFT { shift @{$_[0]->plugin} };
sub UNSHIFT { unshift @{$_[0]->plugin}, $_[1] };
sub SPLICE { @{$_[0]->plugin}, @_}

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

{
	my $lookup = sub { # a lexical sub, if you will
		my $self = shift;
		my $method = shift;

		my $stack = $self->{host}->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 "${$self}{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] }++ if wantarray;
		}

		my $x = $i;
		$i += $self->{offset};

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

		return $stack->[$i] unless wantarray;

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

		return ($stack->[$i], $counts{ $stack->[$i] } - 1);

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

	sub can { # it has to be less ugly than this
		my $self = shift;
		my $method = shift;

		return $self->$lookup($method)->can($method);
	}
	sub AUTOLOAD { # it has to be less ugly than this
		my $self = shift;
		$AUTOLOAD =~ /([^:]*?)$/;
		my $method = $1;
		return undef if $method eq 'DESTROY';

		Object::Meta::Plugin::Host::Context->new($self->{host}, $self->$lookup($method) )->$method(@_);
	}
}

1; # Keep your mother happy.

__END__