File Coverage

blib/lib/MooseX/CustomInitArgs.pm
Criterion Covered Total %
statement 10 12 83.3
branch n/a
condition n/a
subroutine 4 4 100.0
pod n/a
total 14 16 87.5


line stmt bran cond sub pod time code
1             package MooseX::CustomInitArgs;
2              
3             our $AUTHORITY = 'cpan:TOBYINK';
4             our $VERSION = '0.004';
5              
6 1     1   84226 use 5.008;
  1         5  
  1         59  
7 1     1   7 use strict;
  1         2  
  1         44  
8 1     1   5 use warnings;
  1         7  
  1         53  
9 1     1   2025 use Moose::Exporter;
  0            
  0            
10              
11             use constant _AttrTrait => do
12             {
13             package MooseX::CustomInitArgs::Trait::Attribute;
14             our $AUTHORITY = 'cpan:TOBYINK';
15             our $VERSION = '0.004';
16            
17             use Moose::Role;
18             use Moose::Util::TypeConstraints;
19             use B 'perlstring';
20            
21             subtype 'OptList', as 'ArrayRef[ArrayRef]';
22             coerce 'OptList',
23             from 'ArrayRef' => via {
24             require Data::OptList;
25             Data::OptList::mkopt $_;
26             },
27             from 'HashRef' => via {
28             my $hash = $_;
29             [ map { [ $_ => $hash->{$_} ] } sort keys %$hash ];
30             };
31            
32             has init_args => (
33             is => 'ro',
34             isa => 'OptList',
35             predicate => 'has_init_args',
36             coerce => 1,
37             );
38            
39             has _init_args_hashref => (
40             is => 'ro',
41             isa => 'HashRef',
42             lazy => 1,
43             default => sub {
44             my $self = shift;
45             +{ map { ;$_->[0] => $_->[1] } @{$self->init_args} };
46             },
47             );
48            
49             around new => sub
50             {
51             my $orig = shift;
52             my $class = shift;
53             my $self = $class->$orig(@_);
54            
55             if ($self->has_init_args and not $self->has_init_arg)
56             {
57             confess "Attribute ${\$self->name} defined with init_args but no init_arg";
58             }
59            
60             return $self;
61             };
62            
63             sub _inline_param_negotiation
64             {
65             my ($self, $param) = @_;
66             my $init = $self->init_arg;
67            
68             my $regex = join '|', map quotemeta, $self->init_arg, map $_->[0], @{$self->init_args||[]};
69             my $with_coderef = join '|', map quotemeta, map $_->[0], grep { defined($_->[1]) } @{$self->init_args||[]};
70             my $no_coderef = join '|', map quotemeta, map $_->[0], grep { !defined($_->[1]) } @{$self->init_args||[]};
71            
72             return (
73             "if (my \@supplied = grep /^(?:$regex)\$/, keys \%${param}) {",
74             ' if (@supplied > 1) {',
75             ' Carp::confess("Conflicting init_args (@{[join q(, ), sort @supplied]})");',
76             ' }',
77             " elsif (grep /^(?:$no_coderef)\$/, \@supplied) { ",
78             " ${param}->{${\perlstring $self->init_arg}} = delete ${param}->{\$supplied[0]};",
79             " }",
80             " elsif (grep /^($with_coderef)\$/, \@supplied) { ",
81             " my \$x = delete ${param}->{\$supplied[0]};",
82             " ${param}->{${\perlstring $self->init_arg}} = \$MxCIA_attrs{${\$self->name}}->_run_init_coderef(\$supplied[0], \$class, \$x);",
83             " }",
84             "}",
85             );
86             }
87            
88             sub _run_init_coderef
89             {
90             my ($self, $arg, $class, $value) = @_;
91            
92             my $code = $self->_init_args_hashref->{$arg};
93             ref $code eq 'SCALAR' and $code = $$code;
94            
95             if (ref $code eq "MooseX::CustomInitArgs::Sub::AfterTC")
96             {
97             if ($self->should_coerce) {
98             $value = $self->type_constraint->assert_coerce($value);
99             }
100             else {
101             $self->type_constraint->assert_valid($value);
102             }
103             }
104            
105             local $_ = $value;
106             $class->$code($value);
107             }
108            
109             around initialize_instance_slot => sub
110             {
111             my $orig = shift;
112             my $self = shift;
113             my ($meta_instance, $instance, $params) = @_;
114            
115             $self->has_init_args
116             or return $self->$orig(@_);
117            
118             my @supplied = grep { exists $params->{$_->[0]} } @{$self->init_args}
119             or return $self->$orig(@_);
120            
121             if (exists $params->{$self->init_arg})
122             {
123             push @supplied, [ $self->init_arg => undef ];
124             }
125            
126             if (@supplied > 1)
127             {
128             confess sprintf(
129             'Conflicting init_args (%s)',
130             join(', ', sort map $_->[0], @supplied)
131             );
132             }
133            
134             if ($supplied[0][1])
135             {
136             $self->_set_initial_slot_value(
137             $meta_instance,
138             $instance,
139             $self->_run_init_coderef($supplied[0][0], $instance, delete $params->{ $supplied[0][0] }),
140             );
141             }
142             else
143             {
144             $self->_set_initial_slot_value(
145             $meta_instance,
146             $instance,
147             delete $params->{$supplied[0][0]},
148             );
149             }
150            
151             return;
152             };
153            
154             __PACKAGE__;
155             };
156              
157             use constant _ClassTrait => do
158             {
159             package MooseX::CustomInitArgs::Trait::Class;
160             our $AUTHORITY = 'cpan:TOBYINK';
161             our $VERSION = '0.004';
162            
163             use Moose::Role;
164            
165             has _mxcia_hash => (
166             is => 'ro',
167             isa => 'HashRef',
168             lazy => 1,
169             builder => '_build__mxcia_hash',
170             );
171            
172             sub _build__mxcia_hash
173             {
174             my $self = shift;
175             return +{
176             map { ;$_->name => $_ }
177             grep { ;$_->can('does') && $_->does(MooseX::CustomInitArgs->_AttrTrait) }
178             $self->get_all_attributes
179             };
180             }
181            
182             around _eval_environment => sub
183             {
184             my $orig = shift;
185             my $self = shift;
186             my $eval = $self->$orig(@_);
187             $eval->{'%MxCIA_attrs'} = $self->_mxcia_hash;
188             return $eval;
189             };
190            
191             around _inline_slot_initializer => sub
192             {
193             my $orig = shift;
194             my $self = shift;
195             my ($attr, $idx) = @_;
196            
197             return $self->$orig(@_)
198             unless $attr->can('does')
199             && $attr->does(MooseX::CustomInitArgs->_AttrTrait)
200             && $attr->has_init_args;
201            
202             return (
203             $attr->_inline_param_negotiation('$params'),
204             $self->$orig(@_),
205             );
206             };
207            
208             __PACKAGE__;
209             };
210              
211             use constant _ApplicationTrait => do
212             {
213             package MooseX::CustomInitArgs::Trait::Application;
214             our $AUTHORITY = 'cpan:TOBYINK';
215             our $VERSION = '0.004';
216            
217             use Moose::Role;
218              
219             around apply => sub
220             {
221             my $orig = shift;
222             my $self = shift;
223             my ($role, $applied_to) = @_;
224             $applied_to = Moose::Util::MetaRole::apply_metaroles(
225             for => $applied_to->name,
226             class_metaroles => {
227             class => [ MooseX::CustomInitArgs->_ClassTrait ],
228             },
229             role_metaroles => {
230             application_to_class => [ MooseX::CustomInitArgs->_ApplicationTrait ],
231             application_to_role => [ MooseX::CustomInitArgs->_ApplicationTrait ],
232             },
233             );
234             $self->$orig($role, $applied_to);
235             };
236            
237             __PACKAGE__;
238             };
239              
240             sub after_typecheck (&) {
241             bless $_[0], "MooseX::CustomInitArgs::Sub::AfterTC";
242             }
243              
244             sub before_typecheck (&) { $_[0] }
245              
246             Moose::Exporter->setup_import_methods(
247             as_is => [
248             qw( before_typecheck after_typecheck )
249             ],
250             class_metaroles => {
251             class => [ _ClassTrait ],
252             attribute => [ _AttrTrait ],
253             },
254             role_metaroles => {
255             application_to_class => [ _ApplicationTrait ],
256             application_to_role => [ _ApplicationTrait ],
257             applied_attribute => [ _AttrTrait ],
258             },
259             );
260              
261             1;
262              
263             __END__
264              
265             =head1 NAME
266              
267             MooseX::CustomInitArgs - define multiple init args with custom processing
268              
269             =head1 SYNOPSIS
270              
271             package Circle {
272             use Moose;
273             use MooseX::CustomInitArgs;
274            
275             has radius => (
276             is => 'ro',
277             isa => 'Num',
278             required => 1,
279             init_args => [
280             'r',
281             'diameter' => sub { $_ / 2 },
282             ],
283             );
284             }
285            
286             # All three are equivalent...
287             my $circle = Circle->new(radius => 1);
288             my $circle = Circle->new(r => 1);
289             my $circle = Circle->new(diameter => 2);
290              
291             =head1 DESCRIPTION
292              
293             C<MooseX::CustomInitArgs> allows Moose attributes to be initialized from
294             alternative initialization arguments. If you find yourself wishing that
295             Moose's built-in C<init_arg> option took an arrayref, then this is what
296             you want.
297              
298             L<MooseX::MultiInitArg> also does this, but C<MooseX::CustomInitArgs> has
299             an additional feature: it can optionally pre-process each initialization
300             argument. This happens prior to type coercian and constraint checks.
301              
302             (Also at the time of writing, C<MooseX::MultiInitArg> suffers from a bug
303             where it breaks when a class is immutablized.)
304              
305             The constructor cannot be called with multiple initialization arguments
306             for the same attribute. Given the class in the example, this would throw
307             an error:
308              
309             my $circle = Circle->new(radius => 1, diameter => 100);
310              
311             The following would also throw an error, even though it's slightly more
312             sensible:
313              
314             my $circle = Circle->new(radius => 1, diameter => 2);
315              
316             The C<init_args> attribute option is conceptually a hash mapping
317             initialization argument names to methods which pre-process them. The methods
318             can be given as coderefs, or the names of class methods as strings (or scalar
319             refs).
320              
321             You can provide this hash mapping as an actual hashref, or (as in the
322             L</SYNOPSIS>) as an arrayref suitable for input to L<Data::OptList>. In either
323             case it will be coerced to C<MooseX::CustomInitArgs>'s internal representation
324             which is a C<Data::OptList>-style arrayref of arrayrefs.
325              
326             =head2 Interaction with type constraints and coercion
327              
328             =begin trustme
329              
330             =item before_typecheck
331              
332             =item after_typecheck
333              
334             =end trustme
335              
336             Normally, custom init arg coderefs run I<before> the value has been through
337             type constraint checks and coercions. This allows the coderef to massage
338             the value into passing its type constraint checks.
339              
340             However, if you wish to run type constraint checks before the coderef,
341             use the C<after_typecheck> helper:
342              
343             init_args => [
344             'r',
345             'diameter' => after_typecheck { $_ / 2 },
346             ],
347              
348             (There's a corresponding C<before_typecheck> helper for clarity.)
349              
350             After the coderef has been run, type constraint checks and coercions will
351             happen I<again> on the result.
352              
353             =head1 CAVEATS
354              
355             C<init_args> cannot be used on attributes with C<< init_arg => undef >>.
356             C<MooseX::CustomInitArgs> will throw an error if you do.
357              
358             =head1 BUGS
359              
360             Please report any bugs to
361             L<http://rt.cpan.org/Dist/Display.html?Queue=MooseX-CustomInitArgs>.
362              
363             =head1 SEE ALSO
364              
365             L<MooseX::MultiInitArg>, L<MooseX::FunkyAttributes>.
366              
367             =head1 AUTHOR
368              
369             Toby Inkster E<lt>tobyink@cpan.orgE<gt>.
370              
371             =head1 COPYRIGHT AND LICENCE
372              
373             This software is copyright (c) 2013 by Toby Inkster.
374              
375             This is free software; you can redistribute it and/or modify it under
376             the same terms as the Perl 5 programming language system itself.
377              
378             =head1 DISCLAIMER OF WARRANTIES
379              
380             THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
381             WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
382             MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
383