File Coverage

blib/lib/Sub/Lib.pm

Criterion	Covered	Total	%
statement	51	51	100.0
branch	20	20	100.0
condition			n/a
subroutine	15	15	100.0
pod	8	8	100.0
total	94	94	100.0

package Sub::Lib;

use strict;
use warnings;

our $VERSION = '0.02';

sub new {
  my ($class, @args) = @_;

  my $args;
  if(1 == @args) {
    die "reference argument to new() must be a HASH\n"
      unless 'HASH' eq ref $args[0];
    $args = $args[0];
  }
  else {
    die "non-reference argument list to new() must have an even number of elements\n"
      unless 0 == @args % 2;
    $args = {@args};
  }

  # \o/ Lobe den Abgrund
  my $self = bless do {
    my $_lib = { };
    sub {
      my ($name, $sub) = @_;

      return $_lib
        unless defined $name;

      if(defined $sub) {
        die "sub-routine ($name) is not a sub-routine?\n"
          unless 'CODE' eq ref $sub;
        die "sub-routine ($name) already installed in library\n"
          if exists $_lib->{$name};

        $_lib->{$name} = $sub;
      }
      else {
        die "sub-routine ($name) not installed in library\n"
          unless exists $_lib->{$name};
      }

      return $_lib->{$name};
    }
  }, $class;

  $self->($_, $args->{$_})
    for keys %$args;
  return $self;
}

sub has {
  my ($self, $name) = @_;

  my $_lib = $self->();
  return $_lib->{$name};
}

sub run {
  my ($self, $name, @args) = @_;

  return $self->($name)->(@args);
}

sub call {
  my ($self, $name, $object, @args) = @_;

  my $sub = $self->($name);
  return $object->$sub(@args);
}

sub void {
  my ($self, $name) = @_;

  my $_lib = $self->();
  my $sub = exists $_lib->{$name}
    ? $_lib->{$name}
    : sub { return }
  ;

  return $sub;
}

sub curry {
  my ($self, $name, @args) = @_;

  my $sub = $self->($name);
  return sub { $sub->(@args, @_) };
}

sub o {
  my ($self, $name, $object, @args) = @_;

  my $sub = $self->($name);
  return sub { $object->$sub(@args, @_) };
}

sub y {
  my ($self, $name, $sub, @args) = @_;

  die "code reference required for lambda\n"
    unless 'CODE' eq ref $sub;

  return sub { $sub->( $self->($name), @args, @_ ) }
}


1
__END__