File Coverage

blib/lib/Sub/MicroSig.pm

Criterion	Covered	Total	%
statement	49	51	96.0
branch	13	14	92.8
condition	10	12	83.3
subroutine	12	12	100.0
pod			n/a
total	84	89	94.3

use strict;
use warnings;
package Sub::MicroSig;
{
  $Sub::MicroSig::VERSION = '0.033';
}
# ABSTRACT: microsigs for microvalidation of sub arguments

use Exporter 5.57 'import';
use base qw(Exporter);
our @EXPORT = qw(MODIFY_CODE_ATTRIBUTES); ## no critic Export

use Carp ();

use Hook::LexWrap;
use Params::Validate::Micro 0.031 qw(micro_validate); # bugfixes
use Sub::Identify qw(sub_fullname);


my @code_to_sig;

sub MODIFY_CODE_ATTRIBUTES {
  my ($package, $code, @attr) = @_;
  my ($signature, $is_method);
  my @leftovers;

  while (my $attr = shift @attr) {
    if ($attr =~ /\A Sig\(([^)]*)\) \z/x) {
      $signature = $1;
      last;
    } elsif ($attr =~ /\A Meth(?:od)?Sig\(([^)]*)\) \z/x) {
      $signature = $1;
      $is_method = 1;
      last;
    } else {
      push @leftovers, $attr;
    }
  }
  push @leftovers, @attr;

  push @code_to_sig, [ $code, $signature, $is_method ];

  return @leftovers;
}

sub _pre_wrapper {
  my ($signature, $is_method) = @_;

  my $arg_index = $is_method ? 1 : 0;
  my $this      = $is_method ? 'method' : 'sub';

  sub {
    pop; # We're removing $magick so that it doesn't interfere with validation.

    # in other words, if $_[0] can't support methods, you may not call a
    # microsig'd method on it. jeez!
    Carp::croak "microsig'd method not called on a valid invocant"
      if $is_method
      and not eval { $_[0]->can('can'); };

    # In other words, only if an argument was given:
    if ($#_ >= $arg_index) {
      Carp::croak "args to microsig'd $this must be a single array or hash ref"
        if @_ > ($arg_index+1)
        or not(ref $_[$arg_index])
        or ref $_[$arg_index] ne 'HASH' and ref $_[$arg_index] ne 'ARRAY';
    }

    $_[$arg_index] = micro_validate($_[$arg_index], $signature);
  }
}

CHECK {
  for (@code_to_sig) {
    my $wrapper = _pre_wrapper(@$_[1,2]);
    wrap sub_fullname($_->[0]), pre => $wrapper;
  }
}


1;

__END__