File Coverage

blib/lib/Sub/WrapInType.pm

Criterion	Covered	Total	%
statement	102	102	100.0
branch	26	26	100.0
condition			n/a
subroutine	26	26	100.0
pod	5	5	100.0
total	159	159	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( multisig compile compile_named );
use Sub::Util qw( set_subname );
use namespace::autoclean;

our $VERSION = '0.07';
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 {
  my $class = shift;
  state $check = multisig(
    [ $ParamsTypes, $ReturnTypes, CodeRef, $Options, +{ default => sub { $DEFAULT_OPTIONS } } ],
    compile_named(
      params  => $ParamsTypes,
      isa     => $ReturnTypes,
      code    => CodeRef,
      options => $Options, +{ default => sub { $DEFAULT_OPTIONS } },
    ),
  );
  my ($params_types, $return_types, $code, $options) = do {
    my @args = $check->(@_);
    ${^TYPE_PARAMS_MULTISIG} == 0 ? @args : @{ $args[0] }{qw( params isa code options )};
  };
  $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' ? compile(@$params_types)
    : ref $params_types eq 'HASH'  ? compile_named(%$params_types)
    :                                compile($params_types);
  my $return_types_checker =
    ref $return_types eq 'ARRAY' ? compile(@$return_types) : compile($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 = multisig(
    +{ message => << 'EOS' },
USAGE: wrap_sub(\@parameter_types, $return_type, $subroutine)
    or wrap_sub(params => \@params_types, returns => $return_types, code => $subroutine)
EOS
    [ $ParamsTypes, $ReturnTypes, CodeRef ],
    compile_named(
      params => $ParamsTypes,
      isa    => $ReturnTypes,
      code   => CodeRef,
    ),
  );
  my ($params_types, $return_types, $code) = do {
    my @args = $check->(@_);
    ${^TYPE_PARAMS_MULTISIG} == 0 ? @args : @{ $args[0] }{qw( params isa code )};
  };

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

sub wrap_method {
  state $check = multisig(
    +{ message => << 'EOS' },
USAGE: wrap_method(\@parameter_types, $return_type, $subroutine)
    or wrap_method(params => \@params_types, returns => $return_types, code => $subroutine)
EOS
    [ $ParamsTypes, $ReturnTypes, CodeRef ],
    compile_named(
      params => $ParamsTypes,
      isa    => $ReturnTypes,
      code   => CodeRef,
    ),
  );
  my ($params_types, $return_types, $code) = do {
    my @args = $check->(@_);
    ${^TYPE_PARAMS_MULTISIG} == 0 ? @args : @{ $args[0] }{qw( params isa code )};
  };

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

sub install_sub {
  state $check = multisig(
    +{ 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
    [ Str, $ParamsTypes, $ReturnTypes, CodeRef ],
    compile_named(
      name   => Str,
      params => $ParamsTypes,
      isa    => $ReturnTypes,
      code   => CodeRef,
    ),
  );
  my ($name, $params_types, $return_types, $code) = do {
    my @args = $check->(@_);
    ${^TYPE_PARAMS_MULTISIG} == 0 ? @args : @{ $args[0] }{qw( name params isa code )};
  };

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

sub install_method {
  state $check = multisig(
    +{ 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
    [ Str, $ParamsTypes, $ReturnTypes, CodeRef ],
    compile_named(
      name   => Str,
      params => $ParamsTypes,
      isa    => $ReturnTypes,
      code   => CodeRef,
    ),
  );
  my ($name, $params_types, $return_types, $code) = do {
    my @args = $check->(@_);
    ${^TYPE_PARAMS_MULTISIG} == 0 ? @args : @{ $args[0] }{qw( name params isa code )};
  };

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

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

1;

__END__