File Coverage

blib/lib/Pad/Tie.pm

Criterion	Covered	Total	%
statement	46	51	90.2
branch	4	6	66.6
condition	5	10	50.0
subroutine	10	13	76.9
pod	1	6	16.6
total	66	86	76.7

use strict;
use warnings;

package Pad::Tie;

use Pad::Tie::LP;
use Data::OptList;
use Module::Pluggable (
  require => 1,
  except => qr/^Pad::Tie::Plugin::Base::/,
);
use Carp ();

our $VERSION = '0.006';
my %METHOD;

sub new {
  my $class = shift;
  my ($invocant, $methods) = @_;
  $methods = Data::OptList::mkopt($methods);
  my $self = bless {
    invocant => $invocant,
    methods  => $methods,
    persist  => Pad::Tie::LP->new,
    pre_call => [],
  } => $class;
  $self->build_context;
  #tie %{ $self->{context} }, 'Pad::Tie::Context', $self;
  $self->{persist}->set_context(_ => $self->{context});
  return $self;
}

sub build_methods {
  my $class = ref($_[0]) || $_[0];
  for my $plugin ($class->plugins) {
    for my $provided ($plugin->provides) {
      #warn "$plugin provides $provided\n";
      $METHOD{$provided} = $plugin;
    }
  }
}

sub build_context {
  my $self = shift;
  my $methods = shift || $self->{methods};
  $self->{context} ||= {};
  $self->build_methods unless %METHOD;
  for (@$methods) {
    my ($method_personality, $plugin_arg) = @$_;
    Carp::confess "unhandled method personality: $method_personality"
      unless $METHOD{$method_personality};
    my $plugin = $METHOD{$method_personality};
    my $rv = $plugin->$method_personality(
      $self->{context},
      $self->{invocant}, $plugin_arg,
    ) || {};
    # XXX I hate this but I can't think of a better way to do it offhand.
    # if you aren't me, don't use this; talk to me about it instead. -- hdp,
    # 2007-04-24
    if ($rv->{pre_call}) {
      push @{ $self->{pre_call} }, @{ $rv->{pre_call} };
    }
  }
}

sub clone {
  my ($self, $invocant) = @_;
  # XXX validate $invocant?
  # XXX does 'persist' need to be duplicated also?
  # I don't think it has any permanent state that is interesting
  return bless {
    %$self,
    invocant => $invocant,
  } => ref($self),
}

sub call {
  my ($self, $code, @args) = @_;
  $_->($self, $code, \@args) for @{ $self->{pre_call} };
  return $self->{persist}->call($code, @args);
}

sub wrap {
  my ($self, $code) = @_;
  return sub { $self->call($code, @_) };
}

1;

__END__