File Coverage

blib/lib/Method/Generate/Constructor/Role/StrictConstructor.pm
Criterion Covered Total %
statement 9 9 100.0
branch n/a
condition n/a
subroutine 3 3 100.0
pod n/a
total 12 12 100.0


line stmt bran cond sub pod time code
1 1     1   660 use strict; # redundant, but quiets perlcritic
  1         3  
  1         52  
2             package Method::Generate::Constructor::Role::StrictConstructor;
3             $Method::Generate::Constructor::Role::StrictConstructor::VERSION = '0.011';
4             # ABSTRACT: a role to make Moo constructors strict.
5              
6              
7 1     1   6 use Moo::Role;
  1         2  
  1         6  
8 1     1   376 use B ();
  1         3  
  1         234  
9              
10             #
11             # The gist of this code was copied directly from Dave Rolsky's (DROLSKY)
12             # MooseX::StrictConstructor, specifically from
13             # MooseX::StrictConstructor::Trait::Method::Constructor as a modifier around
14             # _generate_BUILDALL. It has diverged only slightly to handle Moo-specific
15             # differences.
16             #
17             around _assign_new => sub {
18             my $orig = shift;
19             my $self = shift;
20             my $spec = $_[0];
21              
22             my @attrs = map { B::perlstring($_) . ' => undef,' }
23             grep {defined}
24             map { $_->{init_arg} } ## no critic (ProhibitAccessOfPrivateData)
25             values(%$spec);
26              
27             my $state = ($] >= 5.010) ? "use feature 'state'; state" : "my";
28              
29             my $body .= <<"EOF";
30              
31             # MooX::StrictConstructor
32             $state \$attrs = { @attrs };
33             my \@bad = sort grep { ! exists \$attrs->{\$_} } keys \%{ \$args };
34             if (\@bad) {
35             die("Found unknown attribute(s) passed to the constructor: " .
36             join ", ", \@bad);
37             }
38              
39             EOF
40              
41             $body .= $self->$orig(@_);
42              
43             return $body;
44             };
45              
46              
47             1;
48              
49             __END__