File Coverage

blib/lib/MooseX/RoleQR.pm
Criterion Covered Total %
statement 15 17 88.2
branch n/a
condition n/a
subroutine 6 6 100.0
pod n/a
total 21 23 91.3


line stmt bran cond sub pod time code
1             package MooseX::RoleQR;
2              
3 2     2   57476 use 5.008;
  2         10  
  2         102  
4 2     2   12 use strict;
  2         18  
  2         79  
5 2     2   12 use warnings;
  2         8  
  2         73  
6 2     2   2914 use utf8;
  2         24  
  2         13  
7              
8             BEGIN {
9 2     2   124 $MooseX::RoleQR::AUTHORITY = 'cpan:TOBYINK';
10 2         37 $MooseX::RoleQR::VERSION = '0.004';
11             }
12              
13 2     2   4071 use Moose ();
  0            
  0            
14             use Moose::Exporter;
15             use Scalar::Does qw( does blessed -constants );
16              
17             Moose::Exporter->setup_import_methods(
18             with_meta => [qw/ before after around /],
19             also => 'Moose::Role',
20             );
21              
22             my %ROLE_METAROLES = (
23             role => ['MooseX::RoleQR::Trait::Role'],
24             application_to_class => ['MooseX::RoleQR::Trait::Application::ToClass'],
25             application_to_role => ['MooseX::RoleQR::Trait::Application::ToRole'],
26             );
27             my %ARGH;
28              
29             sub _add_method_modifier
30             {
31             my $type = shift;
32             my $meta = shift;
33              
34             if (does($_[0], REGEXP) or does($_[0], CODE))
35             {
36             my $pusher = "add_deferred_${type}_method_modifier";
37             return $meta->$pusher(@_);
38             }
39              
40             Moose::Util::add_method_modifier($meta, $type, \@_);
41             }
42              
43             sub before { _add_method_modifier(before => @_) }
44             sub after { _add_method_modifier(after => @_) }
45             sub around { _add_method_modifier(around => @_) }
46              
47             sub init_meta
48             {
49             my $class = shift;
50             my %options = @_;
51             Moose::Role->init_meta(%options);
52            
53             Moose::Util::MetaRole::apply_metaroles(
54             for => $options{for_class},
55             role_metaroles => \%ROLE_METAROLES,
56             );
57             }
58              
59             {
60             no warnings;
61             my $orig = Moose::Meta::Role->can('combine');
62             *Moose::Meta::Role::combine = sub {
63             my ($meta, @role_specs) = @_;
64             my $combo = $meta->$orig(@role_specs);
65             return bless(
66             $combo,
67             Moose::Util::with_traits(
68             ref($combo),
69             'MooseX::RoleQR::Trait::Role::Composite',
70             ),
71             );
72             }
73             };
74              
75             BEGIN {
76             package MooseX::RoleQR::Meta::DeferredModifier;
77             no thanks;
78             use Moose;
79             use Scalar::Does -constants;
80             use namespace::sweep;
81              
82             BEGIN {
83             no warnings;
84             our $AUTHORITY = 'cpan:TOBYINK';
85             our $VERSION = '0.004';
86             };
87              
88             has [qw/ expression body /] => (is => 'ro', required => 1);
89            
90             # sub matches_name
91             # {
92             # my ($meta, $name) = @_;
93             # my $return = $meta->_matches_name($name);
94             # print ($return ? "@{[$meta->expression]} matches $name\n" : "@{[$meta->expression]} does not match $name\n");
95             # return $return;
96             # }
97             #
98             # sub _matches_name
99             sub matches_name
100             {
101             my ($meta, $name, $hints) = @_;
102             my $expr = $meta->expression;
103             return $name =~ $expr if does($expr, REGEXP);
104             return $expr->($name, @{$hints||[]}) if does($expr, CODE); # ssh... secret!
105             return;
106             }
107             };
108              
109             BEGIN {
110             package MooseX::RoleQR::Trait::Role;
111             no thanks;
112             use Moose::Role;
113             use Scalar::Does -constants;
114             use Carp;
115             use namespace::sweep;
116            
117             BEGIN {
118             no warnings;
119             our $AUTHORITY = 'cpan:TOBYINK';
120             our $VERSION = '0.004';
121             };
122              
123             has deferred_modifier_class => (
124             is => 'ro',
125             isa => 'ClassName',
126             lazy => 1,
127             default => sub { 'MooseX::RoleQR::Meta::DeferredModifier' },
128             );
129            
130             for my $type (qw( after around before )) #override
131             {
132             no strict 'refs';
133             my $attr = "deferred_${type}_method_modifiers";
134             has $attr => (
135             traits => ['Array'],
136             is => 'ro',
137             isa => 'ArrayRef[MooseX::RoleQR::Meta::DeferredModifier]',
138             lazy => 1,
139             default => sub { +[] },
140             handles => {
141             "has_deferred_${type}_method_modifiers" => "count",
142             },
143             );
144            
145             my $pusher = "add_deferred_${type}_method_modifier";
146             *$pusher = sub {
147             my ($meta, $expression, $body) = @_;
148             my $modifier = does($expression, 'MooseX::RoleQR::Meta::DeferredModifier')
149             ? $expression
150             : $meta->deferred_modifier_class->new(expression => $expression, body => $body);
151             push @{ $meta->$attr }, $modifier;
152             };
153            
154             around "add_${type}_method_modifier" => sub {
155             my ($orig, $meta, $expression, $body) = @_;
156             if (does($expression, 'MooseX::RoleQR::Meta::DeferredModifier')
157             or does($expression, REGEXP))
158             { return $meta->$pusher($expression, $body) }
159             else
160             { return $meta->$orig($expression, $body) }
161             };
162            
163             next if $type eq 'override';
164             *{"get_deferred_${type}_method_modifiers"} = sub {
165             my ($meta, $name, $hints) = @_;
166             grep { $_->matches_name($name, $hints) } @{ $meta->$attr };
167             };
168             }
169            
170             # sub get_deferred_override_method_modifier
171             # {
172             # my ($meta, $name) = @_;
173             # my @r = grep { $_->matches_name($name) } @{ $meta->deferred_override_method_modifiers };
174             # carp sprintf(
175             # "%s has multiple override modifiers for method %s",
176             # $meta->name,
177             # $name,
178             # ) if @r > 1;
179             # return $r[0];
180             # }
181             };
182              
183             BEGIN {
184             package MooseX::RoleQR::Trait::Role::Composite;
185             no thanks;
186             use Moose::Role;
187             use namespace::sweep;
188            
189             BEGIN {
190             no warnings;
191             our $AUTHORITY = 'cpan:TOBYINK';
192             our $VERSION = '0.004';
193             };
194              
195             after apply => sub {
196             my ($meta, $class) = @_;
197             if ($class->isa('Moose::Meta::Class'))
198             {
199             foreach my $role (@{ $meta->get_roles })
200             {
201             foreach my $modifier_type (qw( before after around ))
202             {
203             MooseX::RoleQR::Trait::Application::ToClass->apply_deferred_method_modifiers(
204             $modifier_type,
205             $role,
206             $class,
207             );
208             }
209             }
210             }
211             else
212             {
213             push @{$ARGH{$class->name}}, map { $_->name } @{ $meta->get_roles };
214             ### Commenting the stuff below out helped pass t/03classattribute.t.
215             ### Not completely sure why. :-(
216             ###
217             # Moose::Util::MetaRole::apply_metaroles(
218             # for => $class->name,
219             # role_metaroles => \%ROLE_METAROLES,
220             # );
221             # bless(
222             # $class,
223             # Moose::Util::with_traits(
224             # ref($class),
225             # 'MooseX::RoleQR::Trait::Role',
226             # ),
227             # );
228             }
229             };
230             };
231              
232             BEGIN {
233             package MooseX::RoleQR::Trait::Application::ToClass;
234             no thanks;
235             use Moose::Role;
236             use namespace::sweep;
237              
238             BEGIN {
239             no warnings;
240             our $AUTHORITY = 'cpan:TOBYINK';
241             our $VERSION = '0.004';
242             };
243              
244             before apply => sub {
245             my ($self, $role, $class) = @_;
246             };
247              
248             # after apply_override_method_modifiers => sub {
249             # my ($self, $role, $class) = @_;
250             # my $modifier_type = 'override';
251             #
252             # my $add = "add_${modifier_type}_method_modifier";
253             # my $get = "get_deferred_${modifier_type}_method_modifiers";
254             #
255             # my @roles = ($role, map { $_->meta } @{$ARGH{$role->name} || []});
256             #
257             # METHOD: for my $method ( $class->get_all_method_names )
258             # {
259             # ROLE: for my $r (@roles)
260             # {
261             # next ROLE unless $r->can($get);
262             # MODIFIER: for ($r->$get($method))
263             # {
264             # $class->$add($method, $_->body);
265             # }
266             # }
267             # }
268             # };
269            
270             after apply_method_modifiers => sub {
271             my ($self, $modifier_type, $role, $class) = @_;
272             $self->apply_deferred_method_modifiers(
273             $modifier_type,
274             $role,
275             $class,
276             );
277             };
278            
279             sub apply_deferred_method_modifiers
280             {
281             my ($self, $modifier_type, $role, $class) = @_;
282             my $add = "add_${modifier_type}_method_modifier";
283             my $get = "get_deferred_${modifier_type}_method_modifiers";
284            
285             my @roles = ($role, map { $_->meta } @{$ARGH{$role->name} || []});
286            
287             METHOD: for my $method ( $class->get_all_method_names )
288             {
289             ROLE: for my $r (@roles)
290             {
291             next ROLE unless $r->can($get);
292             MODIFIER: for ($r->$get($method, \@_))
293             {
294             # warn "@{[$role->name]} modifying @{[$class->name]} method $method";
295             $class->$add($method, $_->body);
296             }
297             }
298             }
299             }
300             };
301              
302             BEGIN {
303             package MooseX::RoleQR::Trait::Application::ToRole;
304             no thanks;
305             use Moose::Role;
306             use namespace::sweep;
307              
308             BEGIN {
309             no warnings;
310             our $AUTHORITY = 'cpan:TOBYINK';
311             our $VERSION = '0.004';
312             };
313              
314             before apply => sub {
315             my ($self, $role1, $role2) = @_;
316             push @{$ARGH{$role2->name}}, $role1->name;
317             Moose::Util::MetaRole::apply_metaroles(
318             for => $role2->name,
319             role_metaroles => \%ROLE_METAROLES,
320             );
321             bless(
322             $role2,
323             Moose::Util::with_traits(
324             ref($role2),
325             'MooseX::RoleQR::Trait::Role',
326             ),
327             );
328             };
329             };
330              
331             1;
332              
333             __END__
334              
335             =head1 NAME
336              
337             MooseX::RoleQR - allow "before qr{...} => sub {...};" in roles
338              
339             =head1 SYNOPSIS
340              
341             {
342             package Local::Role;
343             use MooseX::RoleQR;
344             after qr{^gr} => sub {
345             print " World\n";
346             };
347             }
348            
349             {
350             package Local::Class;
351             use Moose;
352             with qw( Local::Role );
353             sub greet {
354             print "Hello";
355             }
356             }
357            
358             Local::Class->new->greet; # prints "Hello World\n"
359              
360             =head1 DESCRIPTION
361              
362             Method modifiers in Moose classes can be specified using regular expressions
363             a la:
364              
365             before qr{...} => sub {...};
366              
367             However, this is not allowed in Moose roles because Moose doesn't know which
368             class the role will be composed with, and thus doesn't know which method
369             names match the regular expression. Let's change that.
370              
371             This module implements regular expression matched method modifiers for Moose
372             roles. It does so by deferring the calculation of which methods to modify
373             until role application time.
374              
375             The current implementation handles only C<before>, C<after> and C<around>
376             modifiers (not C<override>), and thus it overrides the following standard
377             Moose::Role keywords:
378              
379             =over
380              
381             =item C<< before Str|ArrayRef|RegexpRef => CodeRef >>
382              
383             =item C<< after Str|ArrayRef|RegexpRef => CodeRef >>
384              
385             =item C<< around Str|ArrayRef|RegexpRef => CodeRef >>
386              
387             =back
388              
389             =begin trustme
390              
391             =item C<init_meta>
392              
393             =end trustme
394              
395             =head2 Caveat Regarding the Order of Method Modifiers
396              
397             Moose executes method modifiers in a well-defined order (see
398             L<Moose::Manual::MethodModifiers> for details). This module has the potential
399             to disrupt that order, as regular expression matched modifiers are always
400             applied after the role's other modifiers have been applied.
401              
402             =head2 Caveat: no C<< use Moose::Role >>
403              
404             You should C<< use MooseX::RoleQR >> I<instead of> Moose::Role; not
405             I<as well as>.
406              
407             =head2 General Caveat
408              
409             There's some pretty nasty stuff under the hood. Let's pretend it's
410             not there.
411              
412             =head1 BUGS
413              
414             Please report any bugs to
415             L<http://rt.cpan.org/Dist/Display.html?Queue=MooseX-RoleQR>.
416              
417             =head1 SEE ALSO
418              
419             L<Moose::Role>.
420              
421             =head1 AUTHOR
422              
423             Toby Inkster E<lt>tobyink@cpan.orgE<gt>.
424              
425             =head1 COPYRIGHT AND LICENCE
426              
427             This software is copyright (c) 2012 by Toby Inkster.
428              
429             This is free software; you can redistribute it and/or modify it under
430             the same terms as the Perl 5 programming language system itself.
431              
432             =head1 DISCLAIMER OF WARRANTIES
433              
434             THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
435             WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
436             MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
437