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


line stmt bran cond sub pod time code
1 3     3   82367 use strict;
  3         8  
  3         122  
2 3     3   17 use warnings;
  3         7  
  3         343  
3             package Sub::MicroSig;
4             {
5             $Sub::MicroSig::VERSION = '0.033';
6             }
7             # ABSTRACT: microsigs for microvalidation of sub arguments
8              
9 3     3   16 use Exporter 5.57 'import';
  3         89  
  3         128  
10 3     3   19 use base qw(Exporter);
  3         6  
  3         339  
11             our @EXPORT = qw(MODIFY_CODE_ATTRIBUTES); ## no critic Export
12              
13 3     3   19 use Carp ();
  3         6  
  3         77  
14              
15 3     3   2717 use Hook::LexWrap;
  3         14117  
  3         21  
16 3     3   2899 use Params::Validate::Micro 0.031 qw(micro_validate); # bugfixes
  3         48516  
  3         217  
17 3     3   2648 use Sub::Identify qw(sub_fullname);
  3         3311  
  3         1590  
18              
19              
20             my @code_to_sig;
21              
22             sub MODIFY_CODE_ATTRIBUTES {
23 5     5   11218 my ($package, $code, @attr) = @_;
24 5         9 my ($signature, $is_method);
25 0         0 my @leftovers;
26              
27 5         22 while (my $attr = shift @attr) {
28 5 100       42 if ($attr =~ /\A Sig\(([^)]*)\) \z/x) {
    50          
29 2         7 $signature = $1;
30 2         6 last;
31             } elsif ($attr =~ /\A Meth(?:od)?Sig\(([^)]*)\) \z/x) {
32 3         9 $signature = $1;
33 3         4 $is_method = 1;
34 3         7 last;
35             } else {
36 0         0 push @leftovers, $attr;
37             }
38             }
39 5         7 push @leftovers, @attr;
40              
41 5         22 push @code_to_sig, [ $code, $signature, $is_method ];
42              
43 5         17 return @leftovers;
44             }
45              
46             sub _pre_wrapper {
47 5     5   14 my ($signature, $is_method) = @_;
48              
49 5 100       18 my $arg_index = $is_method ? 1 : 0;
50 5 100       14 my $this = $is_method ? 'method' : 'sub';
51              
52             sub {
53 26     26   26974 pop; # We're removing $magick so that it doesn't interfere with validation.
54              
55             # in other words, if $_[0] can't support methods, you may not call a
56             # microsig'd method on it. jeez!
57             Carp::croak "microsig'd method not called on a valid invocant"
58             if $is_method
59 26 100 100     89 and not eval { $_[0]->can('can'); };
  17         149  
60              
61             # In other words, only if an argument was given:
62 25 100       75 if ($#_ >= $arg_index) {
63 22 100 100     265 Carp::croak "args to microsig'd $this must be a single array or hash ref"
      66        
      66        
64             if @_ > ($arg_index+1)
65             or not(ref $_[$arg_index])
66             or ref $_[$arg_index] ne 'HASH' and ref $_[$arg_index] ne 'ARRAY';
67             }
68              
69 21         83 $_[$arg_index] = micro_validate($_[$arg_index], $signature);
70             }
71 5         33 }
72              
73             CHECK {
74 3     3   3399 for (@code_to_sig) {
75 5         120 my $wrapper = _pre_wrapper(@$_[1,2]);
76 5         25 wrap sub_fullname($_->[0]), pre => $wrapper;
77             }
78             }
79              
80              
81             1;
82              
83             __END__