File Coverage

blib/lib/Sub/Pipeline.pm

Criterion	Covered	Total	%
statement	94	109	86.2
branch	25	36	69.4
condition	4	8	50.0
subroutine	25	28	89.2
pod	11	11	100.0
total	159	192	82.8

use strict;
use warnings;
package Sub::Pipeline;
{
  $Sub::Pipeline::VERSION = '0.011';
}
# ABSTRACT: subs composed of sequential pieces

use Carp ();
use Params::Util 0.22 qw(_CODELIKE);
use Sub::Install;


sub new {
  my ($class, $arg) = @_;
  $arg->{on_success} ||= 'value';

  my $self = bless {} => $class;

  $self->order(@{ $arg->{order} }) if $arg->{order};
  $self->pipe($_ => $arg->{pipe}{$_}) for (keys %{ $arg->{pipe} });
  $self->on_success($arg->{on_success});

  return $self;
}


sub order {
  my $self = shift;
  return @{ $self->{order} } unless @_;

  $self->{order} = [ @_ ];
  return @_;
}


sub pipe { ## no critic Homonym
  my ($self, $name, $code) = @_;
  return $self->{pipe}{$name} if @_ == 2;
  Carp::croak "pipe piece must be a code reference" unless ref $code eq 'CODE';
  $self->{pipe}{$name} = $code;
}


my %_behavior = map { $_ => 1 } qw(throw return value);

sub on_success {
  my $self = shift;
  return $self->{behavior} unless @_;

  my ($behavior) = @_;
  Carp::croak "invalid value for on_success" unless $_behavior{ $behavior };
  $self->{behavior} = $behavior;
}


sub check {
  my ($self) = @_;
  for my $pipe ($self->order) {
    my $code = $self->pipe($pipe);
    unless ((ref $code eq 'CODE') or overload::Method($code, '&{}')) {
      Sub::Pipeline::PipeMissing->throw(pipe => $pipe);
    }
  }
  return 1;
}


sub _initial_state {
  my ($self) = @_;
  return {};
}

sub _call_parts {
  my ($self, $order, $on_success, $get_part, $arg) = @_;

  push @$arg, $self->_initial_state;

  for my $pipe (@$order) {
    my $code = $get_part->($pipe);
    unless (_CODELIKE($code)) {
      Sub::Pipeline::PipeMissing->throw(pipe => $pipe);
    }
    eval { $code->(@$arg) };
    next unless $@;
    if (my $e = Sub::Pipeline::Success->caught) {
      return $e if $on_success eq 'return';
      return $e->value if $on_success eq 'value';
      $e->rethrow if $on_success eq 'throw';
      Carp::confess "unknown on_success behavior: " . $on_success;
    } else {
      Carp::cluck $@;
    }
  }
}

sub call {
  my $self = shift;

  $self->_call_parts(
    [ $self->order ],
    $self->on_success,
    sub { $self->pipe($_[0]) },
    \@_
  );
}


sub as_code {
  my ($self) = @_;
  sub { $self->call(@_) };
}


sub load_from_package {
  my ($self, $package) = @_;

  for my $pipe ($self->order) {
    my $code = $package->can($pipe);
    Carp::croak "package $package has no sub $pipe" unless $code;
    $self->pipe($pipe => $code);
  }
}


sub save_to_package {
  my ($self, $package, $arg) = @_;

  my $installer
    = Sub::Install->can($arg->{reinstall} ? 'reinstall_sub' : 'install_sub');

  for my $pipe ($self->order) {
    $installer->({
      into => $package,
      as   => $pipe,
      code => $self->pipe($pipe),
    });
  }

  my $on_success = $self->on_success;

  my $caller = sub {
    $self->_call_parts(
      [ $self->order ],
      $self->on_success,
      $package->can($_[0]),
      \@_,
    );
  };

  $installer->({ into => $package, as => 'call', code => $caller });
}


sub install_pipeline {
  my ($self, $arg) = @_;

  ($arg->{into}) ||= caller(0);

  my $installer
    = Sub::Install->can($arg->{reinstall} ? 'reinstall_sub' : 'install_sub');

  Carp::croak "install_pipeline requires an 'as' parameter" unless $arg->{as};
  $installer->({
    code => $self->as_code,
    into => $arg->{into},
    as   => $arg->{as}
  });
}


sub install_new {
  my ($self, $arg) = @_;

  my $install_arg = {};
  $install_arg->{$_} = delete $arg->{$_} for qw(into as reinstall);

  $self->new($arg)->install_pipeline($install_arg);
}

use overload
  '&{}'    => 'as_code',
  fallback => 1
;

use Sub::Exporter 0.95 -setup => {
  groups     => { class => \&_class_generator },
  collectors => [ order => sub { ref $_[0] eq 'ARRAY' } ],
};

sub _class_generator {
  my ($class, $name, $arg, $col) = @_;

  my @order = @{ $col->{order} };

  my $order_acc = sub { return @_ ? (@order = @_) : @order; };
  my $caller    = sub {
    my ($self) = @_;
    $class->_call_parts(
      [ $order_acc->() ],
      'value', # make configurable
      sub { $self->can($_[0]) },
      \@_,
    );
  };

  return {
    order => $order_acc,
    call  => $caller,
  };
}


use Exception::Class 1.22 (
  'Sub::Pipeline::Success',     { fields => [qw(value)] },
  'Sub::Pipeline::PipeMissing', { fields => [qw(pipe) ] },
);


1;

__END__