view release on metacpan or  search on metacpan

lib/Sub/DeferredPartial.pm  view on Meta::CPAN

package Sub::DeferredPartial;

our $VERSION = '0.01';

use Sub::DeferredPartial::Attributes();
use Sub::DeferredPartial::Op::Nullary();
use Sub::DeferredPartial::Op::Unary();
use Sub::DeferredPartial::Op::Binary();
use Carp;

use overload
  '&{}'    => 'Subify'
, '""'     => 'Describe'
, nomethod => 'NoMethod'
;
# -----------------------------------------------------------------------------
sub import
# -----------------------------------------------------------------------------
{
  my $class  = shift;
  my $Name   = shift || 'defer';
  my $Caller = caller;

  *{"$Caller\::$Name"} = \&Defer;
  Sub::DeferredPartial::Attributes->import( $Caller );
}
# -----------------------------------------------------------------------------
sub new
# -----------------------------------------------------------------------------
{
  my $class = shift;
  my $Sub   = shift;
  my $Free  = shift;
  my $Bound = shift || {};

  bless { Sub => $Sub, F => $Free, B => $Bound } => $class;
}
# -----------------------------------------------------------------------------
sub Subify
# -----------------------------------------------------------------------------
{
  my $self = shift;

  return sub { return @_ ? $self->Apply( @_ ) : $self->Eval };
}
# -----------------------------------------------------------------------------
sub Apply
# -----------------------------------------------------------------------------
{
  my $self = shift;
  my %Args = @_;
  my %F    = %{$self->{F}};
  my %B    = %{$self->{B}};

  while ( my ( $k, $v ) = each %Args )
  {
    confess "Bound parameter: $k" if     exists $B{$k}; $B{$k} = $v;
    confess "Wrong parameter: $k" unless exists $F{$k}; delete $F{$k};
  }
  return ref( $self )->new( $self->{Sub}, \%F, \%B );
}
# -----------------------------------------------------------------------------
sub Eval
# -----------------------------------------------------------------------------
{
  my $self = shift;

  confess "Free parameter: $_" for keys %{$self->{F}};

  return $self->{Sub}->( %{$self->{B}} );
}
# -----------------------------------------------------------------------------
sub Free
# -----------------------------------------------------------------------------
{
  my $self = shift;

  return $self->{F};
}
# -----------------------------------------------------------------------------
sub Describe
# -----------------------------------------------------------------------------
{
  my $self = shift;
  my @s;

  while ( my ( $k, $v ) = each %{$self->{B}} ) { push @s, "$k => $v"; }
  while ( my ( $k, $v ) = each %{$self->{F}} ) { push @s, "$k => ?" ; }

  return $self->{Sub} . ': ' . join ', ', @s;
}
# -----------------------------------------------------------------------------
sub NoMethod
# -----------------------------------------------------------------------------
{
  my ( $Obj1, $Obj2, $Inv, $Op ) = @_;