File Coverage

blib/lib/MooX/AttributeFilter.pm
Criterion Covered Total %
statement 35 41 85.3
branch 6 6 100.0
condition 6 10 60.0
subroutine 9 9 100.0
pod n/a
total 56 66 84.8


line stmt bran cond sub pod time code
1             # ABSTRACT: Implements 'filter' option for Moo-class attributes
2              
3              
4             package MooX::AttributeFilter;
5 3     3   385537 use v5.10;
  3         17  
6 3     3   1052 use strictures 1;
  3         3348  
  3         78  
7              
8             our $VERSION = '0.002902'; # TRIAL
9              
10 3     3   206 use Carp;
  3         6  
  3         159  
11 3     3   16 use Scalar::Util qw;
  3         6  
  3         96  
12 3     3   1059 use Class::Method::Modifiers qw(install_modifier);
  3         3217  
  3         120  
13 3     3   1023 use Sub::Quote qw;
  3         9781  
  3         2423  
14             require Method::Generate::Accessor;
15              
16             my %filterClasses;
17              
18             sub _generate_filter_source {
19 101     101   106 my $this = shift;
20 101         173 my ( $me, $name, $spec, $source ) = @_;
21              
22 101 100 100     286 if ( $spec->{filter} && $spec->{filter_sub} ) {
23 63         149 $this->{captures}{ '$filter_for_' . $name } = \$spec->{filter_sub};
24             $source =
25             $this->_generate_call_code( $name, 'filter', "${me}, ${source}",
26 63         158 $spec->{filter_sub} );
27             }
28              
29 101         1214 return $source;
30             }
31              
32             install_modifier "Method::Generate::Accessor", 'around', '_generate_core_set',
33             sub {
34             my $orig = shift;
35             my $this = shift;
36             my ( $me, $name, $spec, $source ) = @_;
37              
38             unless ( $spec->{".filter_dont_generate"} ) {
39             $source = _generate_filter_source( $this, $me, $name, $spec, $source );
40             }
41              
42             return $orig->( $this, $me, $name, $spec, $source );
43             };
44              
45             install_modifier "Method::Generate::Accessor", 'around', 'is_simple_set', sub {
46             my $orig = shift;
47             my $this = shift;
48             my ( $name, $spec ) = @_;
49             return $orig->( $this, @_ ) && !( $spec->{filter} && $spec->{filter_sub} );
50             };
51              
52             install_modifier "Method::Generate::Accessor", 'around',
53             '_generate_use_default', sub {
54             my $orig = shift;
55             my $this = shift;
56             my ( $me, $name, $spec, $test ) = @_;
57              
58             # Prevent double generation for lazy attributes with default/builder.
59             $spec->{'.filter_dont_generate'} = 1;
60             return $orig->( $this, @_ );
61             };
62              
63             install_modifier "Method::Generate::Accessor", 'around',
64             '_generate_get_default', sub {
65             my $orig = shift;
66             my $this = shift;
67             my ( $me, $name, $spec ) = @_;
68              
69             my $default = $orig->( $this, $me, $name, $spec );
70              
71             return _generate_filter_source( $this, $me, $name, $spec, $default );
72             };
73              
74             install_modifier "Method::Generate::Accessor", 'around',
75             '_generate_populate_set', sub {
76             my $orig = shift;
77             my $this = shift;
78             my ( $me, $name, $spec, $source, $test, $init_arg ) = @_;
79             local $spec->{".filter_dont_generate"} = 1;
80              
81             if ( !$this->has_eager_default( $name, $spec ) ) {
82             $source = _generate_filter_source( $this, $me, $name, $spec, $source );
83             }
84              
85             return $orig->( $this, $me, $name, $spec, $source, $test, $init_arg );
86             };
87              
88             install_modifier "Method::Generate::Accessor", 'around', '_generate_set', sub {
89             my $orig = shift;
90             my $this = shift;
91             my ( $name, $spec ) = @_;
92             local $spec->{".filter_dont_generate"} = 1;
93              
94             my $rc = $orig->( $this, @_ );
95              
96             return $rc unless $spec->{filter} && $spec->{filter_sub};
97              
98             my $capName = '$filter_for_' . $name;
99              
100             # Call to the filter was generated already.
101             unless ( $this->{captures}{$capName} ) {
102              
103             # Work around Method::Generate::Accessor limitation: it predefines
104             # source as being $_[1] only and not acceping any argument to define it
105             # externally. For this purpose the only solution we have is to wrap it
106             # into a sub and pass the filter as sub's argument.
107              
108             my $name_str = quotify $name;
109             $rc = "sub { $rc }->( \$_[0], "
110             . $this->_generate_call_code( $name, 'filter',
111             "\$_[0], \$_[1], \$_[0]->{${name_str}}",
112             $spec->{filter_sub} )
113             . " )";
114             }
115              
116             return $rc;
117             };
118              
119             install_modifier "Method::Generate::Accessor", 'around', 'generate_method',
120             sub {
121             my $orig = shift;
122             my $this = shift;
123             my ( $into, $name, $spec, $quote_opts ) = @_;
124              
125             if ( $filterClasses{$into} && $spec->{filter} ) {
126              
127             croak "Incompatibe 'is' option '$spec->{is}': can't install filter"
128             unless $spec->{is} =~ /^rwp?$/;
129              
130             my $filterSub;
131             if ( $spec->{filter} eq 1 ) {
132             $filterSub = "_filter_${name}";
133             }
134             else {
135             $filterSub = $spec->{filter};
136             }
137              
138             # $spec->{filter} = 1;
139              
140             croak "Attribute '$name' filter option has invalid value"
141             if ref($filterSub) && ref($filterSub) ne 'CODE';
142              
143             my $filterCode = ref($filterSub) ? $filterSub : $into->can($filterSub);
144              
145             croak
146             "No filter method '$filterSub' defined for $into attribute '$name'"
147             unless $filterCode;
148              
149             $spec->{filter_sub} = $filterCode;
150             }
151              
152             return $orig->( $this, @_ );
153             };
154              
155             sub import {
156 61     61   205973 my ($class) = @_;
157 61         114 my $target = caller;
158              
159 61 100 66     333 my $trait =
160             Role::Tiny->can('is_role')
161             && Role::Tiny->is_role($target)
162             ? 'MooseX::AttributeFilter::Trait::Attribute::Role'
163             : 'MooseX::AttributeFilter::Trait::Attribute';
164              
165 61         264 $filterClasses{$target} = 1;
166             install_modifier $target, 'around', 'has', sub {
167 80     80   50917 my $orig = shift;
168 80         233 my ( $attr, %opts ) = @_;
169 80 100       223 return $orig->( $attr, %opts ) unless $opts{filter};
170 59   50     237 $opts{moosify} ||= [];
171 59         228 push @{ $opts{moosify} }, sub {
172 0         0 my ($spec) = @_;
173             require # hide from CPANTS
174 0         0 MooseX::AttributeFilter;
175 0   0     0 $spec->{traits} ||= [];
176 0         0 $spec->{bypass_filter_method_check} = 1;
177 0         0 push @{ $spec->{traits} }, $trait;
  0         0  
178 59         82 };
179 59         187 $orig->( $attr, %opts );
180 61         308 };
181             }
182              
183             1;
184              
185             __END__