File Coverage

blib/lib/Sub/WrapInType.pm

Criterion	Covered	Total	%
statement	87	87	100.0
branch	16	16	100.0
condition			n/a
subroutine	26	26	100.0
pod	5	5	100.0
total	134	134	100.0

package Sub::WrapInType;
use 5.010001;
use strict;
use warnings;
use parent 'Exporter';
use Class::InsideOut qw( register readonly id );
use Types::Standard -types;
use Type::Params qw( signature );
use Sub::Util qw( set_subname );
use namespace::autoclean;

our $VERSION = '0.08';
our @EXPORT  = qw( wrap_sub wrap_method install_sub install_method );

readonly params    => my %params;
readonly returns   => my %returns;
readonly code      => my %code;
readonly is_method => my %is_method;

my $TypeConstraint  = HasMethods[qw( check get_message )];
my $ParamsTypes     = $TypeConstraint | ArrayRef[$TypeConstraint] | Map[Str, $TypeConstraint];
my $ReturnTypes     = $TypeConstraint | ArrayRef[$TypeConstraint];
my $Options         = Dict[
  skip_invocant => Optional[Bool],
  check         => Optional[Bool],
];
my $DEFAULT_OPTIONS = +{
  skip_invocant => 0,
  check         => 1,
};

sub new {
  state $check = signature(
    method => 1,
    multi => [
      +{
        positional => [
          $ParamsTypes,
          $ReturnTypes,
          CodeRef,
          $Options, +{ default => sub { $DEFAULT_OPTIONS } }
        ],
      },
      +{
        named_to_list => 1,
        named => [
          params  => $ParamsTypes,
          isa     => $ReturnTypes,
          code    => CodeRef,
          options => $Options, +{ default => sub { $DEFAULT_OPTIONS } },
        ],
      },
    ],
  );
  my ($class, $params_types, $return_types, $code, $options) = $check->(@_);
  $options = +{ %$DEFAULT_OPTIONS, %$options };

  my $typed_code =
      $options->{check}
    ? $class->_create_typed_code($params_types, $return_types, $code, $options)
    : sub { $code->(@_) };

  my $self = bless $typed_code, $class;
  register($self);

  {
    my $addr = id $self;
    $params{$addr}    = $params_types;
    $returns{$addr}   = $return_types;
    $code{$addr}      = $code;
    $is_method{$addr} = !!$options->{skip_invocant};
  }

  $self;
}

sub _create_typed_code {
  my ($class, $params_types, $return_types, $code, $options) = @_;
  my $params_types_checker =
      ref $params_types eq 'ARRAY' ? signature(positional => $params_types)
    : ref $params_types eq 'HASH'  ? signature(named => [%$params_types], bless => 0)
    :                                signature(positional => [$params_types]);
  my $return_types_checker =
    ref $return_types eq 'ARRAY' ? signature(positional => $return_types)
    :                              signature(positional => [$return_types]);

  if ( ref $return_types eq 'ARRAY' ) {
    if ( $options->{skip_invocant} ) {
      sub {
        my @return_values = $code->( shift, $params_types_checker->(@_) );
        $return_types_checker->(@return_values);
        @return_values;
      };
    }
    else {
      sub {
        my @return_values = $code->( $params_types_checker->(@_) );
        $return_types_checker->(@return_values);
        @return_values;
      };
    }
  }
  else {
    if ( $options->{skip_invocant} ) {
      sub {
        my $return_value = $code->( shift, $params_types_checker->(@_) );
        $return_types_checker->($return_value);
        $return_value;
      };
    }
    else {
      sub {
        my $return_value = $code->( $params_types_checker->(@_) );
        $return_types_checker->($return_value);
        $return_value;
      };
    }
  }
}

sub _is_env_ndebug {
  $ENV{PERL_NDEBUG} || $ENV{NDEBUG};
}

sub wrap_sub {
  state $check = signature(
    message => << 'EOS',
USAGE: wrap_sub(\@parameter_types, $return_type, $subroutine)
    or wrap_sub(params => \@params_types, returns => $return_types, code => $subroutine)
EOS
    multi => [
      +{ positional => [ $ParamsTypes, $ReturnTypes, CodeRef ] },
      +{
        named_to_list => 1,
        named => [
          params => $ParamsTypes,
          isa    => $ReturnTypes,
          code   => CodeRef,
        ],
      },
    ],
  );
  my ($params_types, $return_types, $code) = $check->(@_);

  __PACKAGE__->new($params_types, $return_types, $code, +{ check => !_is_env_ndebug() });
}

sub wrap_method {
  state $check = signature(
    message => << 'EOS',
USAGE: wrap_method(\@parameter_types, $return_type, $subroutine)
    or wrap_method(params => \@params_types, returns => $return_types, code => $subroutine)
EOS
    multi => [
      +{ positional => [ $ParamsTypes, $ReturnTypes, CodeRef ] },
      +{
        named_to_list => 1,
        named => [
          params => $ParamsTypes,
          isa    => $ReturnTypes,
          code   => CodeRef,
        ],
      },
    ],
  );
  my ($params_types, $return_types, $code) = $check->(@_);

  my $options = +{
    skip_invocant => 1,
    check         => !_is_env_ndebug(),
  };
  __PACKAGE__->new($params_types, $return_types, $code, $options);
}

sub install_sub {
  state $check = signature(
    message => << 'EOS',
USAGE: install_sub($name, \@parameter_types, $return_type, $subroutine)
    or install_sub(name => $name, params => \@params_types, returns => $return_types, code => $subroutine)
EOS
    multi => [
      +{ positional => [ Str, $ParamsTypes, $ReturnTypes, CodeRef ] },
      +{
        named_to_list => 1,
        named => [
          name   => Str,
          params => $ParamsTypes,
          isa    => $ReturnTypes,
          code   => CodeRef,
        ],
      },
    ],
  );
  my ($name, $params_types, $return_types, $code) = $check->(@_);

  _install($name, wrap_sub($params_types, $return_types, $code), scalar caller);
}

sub install_method {
  state $check = signature(
    message => << 'EOS',
USAGE: install_method($name, \@parameter_types, $return_type, $subroutine)
    or install_method(name => $name, params => \@params_types, returns => $return_types, code => $subroutine)
EOS
    multi => [
      +{ positional => [ Str, $ParamsTypes, $ReturnTypes, CodeRef ] },
      +{
        named => [
          name   => Str,
          params => $ParamsTypes,
          isa    => $ReturnTypes,
          code   => CodeRef,
        ],
        named_to_list => 1,
      },
    ],
  );
  my ($name, $params_types, $return_types, $code) = $check->(@_);

  _install($name, wrap_method($params_types, $return_types, $code), scalar caller);
}

sub _install {
  my ($name, $code, $pkg) = @_;
  my $fullname = "${pkg}::${name}";
  {
    no strict 'refs';
    *{$fullname} = $code;
  }
  set_subname($fullname, $code);
}

1;

__END__