File Coverage

blib/lib/MooseX/NiftyDelegation.pm
Criterion Covered Total %
statement 28 37 75.6
branch 0 2 0.0
condition n/a
subroutine 10 15 66.6
pod n/a
total 38 54 70.3


line stmt bran cond sub pod time code
1 1     1   23720 use 5.008;
  1         4  
  1         38  
2 1     1   5 use strict;
  1         2  
  1         36  
3 1     1   5 use warnings;
  1         6  
  1         27  
4 1     1   1059 use utf8;
  1         11  
  1         5  
5              
6             {
7             package MooseX::NiftyDelegation;
8 1     1   2899 no thanks;
  1         230  
  1         6  
9             our $AUTHORITY = 'cpan:TOBYINK';
10             our $VERSION = '0.003';
11             use constant {
12 1         127 Nifty => 'MooseX::NiftyDelegation::Trait::Attribute',
13 1     1   113 };
  1         2  
14 1         12 use Sub::Exporter -setup => {
15             exports => [qw/ Nifty value_is value_like /],
16             groups => { default => [qw/ Nifty /] },
17 1     1   4524 };
  1         21726  
18 1     1   432 use Scalar::Util qw( looks_like_number );
  1         1  
  1         160  
19             sub value_is ($) {
20 0     0     my $test = shift;
21             looks_like_number($test)
22 0     0     ? sub { $_ == $test }
23 0 0   0     : sub { $_ eq $test };
  0            
24             }
25             sub value_like ($) {
26 0     0     my $test = shift;
27 0     0     sub { $_ =~ $test };
  0            
28             }
29             }
30              
31             {
32             package MooseX::NiftyDelegation::Trait::Attribute;
33 1     1   5 no thanks;
  1         1  
  1         7  
34             our $AUTHORITY = 'cpan:TOBYINK';
35             our $VERSION = '0.003';
36 1     1   469 use Moose::Role;
  0            
  0            
37             around _canonicalize_handles => sub {
38             my $orig = shift;
39             my $self = shift;
40             my %hash = $self->$orig(@_);
41             my $attr;
42             for my $k (keys %hash) {
43             next unless ref(my $body = $hash{$k});
44             $attr ||= ($self->get_read_method || $self->get_read_method_ref);
45             $hash{$k} = sub {
46             local $_ = $_[0]->$attr;
47             $body->(@_);
48             };
49             };
50             return %hash;
51             };
52             }
53              
54             1;
55             __END__
56              
57             =head1 NAME
58              
59             MooseX::NiftyDelegation - extra sugar for method delegation
60              
61             =head1 SYNOPSIS
62              
63             use 5.014;
64             use strict;
65             use warnings;
66            
67             package My::Process {
68             use Moose;
69             use MooseX::NiftyDelegation -all;
70            
71             has status => (
72             is => 'rw',
73             isa => 'Str',
74             traits => [ Nifty ],
75             required => 1,
76             handles => {
77             is_in_progress => value_is 'in progress',
78             is_failed => value_is 'failed',
79             is_complete => value_like qr/^complete/,
80             completion_date => sub { /^completed (.+)$/ and $1 },
81             },
82             );
83             }
84            
85             package main {
86             use Test::More;
87            
88             my $process = My::Process->new(
89             status => 'completed 2012-11-19',
90             );
91            
92             ok( not $process->is_in_progress );
93             ok( not $process->is_failed );
94             ok( $process->is_complete );
95            
96             is( $process->completion_date, '2012-11-19' );
97            
98             done_testing;
99             }
100              
101             =head1 DESCRIPTION
102              
103             Moose has an undocumented feature whereby you can delegate methods to
104             coderefs like this:
105              
106             has status => (
107             is => 'rw',
108             isa => 'Str',
109             handles => {
110             is_in_progress => sub {
111             my $self = shift;
112             $self->status eq 'in progress';
113             },
114             },
115             );
116              
117             Kinda ugly though. The C<MooseX::NiftyDelegation::Trait::Attribute> trait
118             pretties it up a little by automatically wrapping the coderef with a little
119             gubbin that sets C<< $_ >> to C<< $self->$attribute >>. Thus:
120              
121             has status => (
122             is => 'rw',
123             isa => 'Str',
124             traits => ['MooseX::NiftyDelegation::Trait::Attribute'],
125             handles => {
126             is_in_progress => sub { $_ eq 'in progress' },
127             },
128             );
129              
130             A little prettier. The rest of C<MooseX::NiftyDelegation> gives you some
131             handy functions to make these coderefs a cuter still...
132              
133             =over
134              
135             =item C<< Nifty >>
136              
137             This is a constant which returns the string
138             C<< 'MooseX::NiftyDelegation::Trait::Attribute' >> so you don't have to
139             type that out every time. It is exported by default.
140              
141             =item C<< value_is $number >>
142              
143             Returns a coderef that evaluates C<< $_ >> for numeric equality with the
144             given number. This function is not exported by default.
145              
146             =item C<< value_is $string >>
147              
148             Returns a coderef that evaluates C<< $_ >> for string equality with the
149             given string. This function is not exported by default.
150              
151             =item C<< value_like $regexp >>
152              
153             Returns a coderef that evaluates C<< $_ >> for matching the given
154             regular expression. This function is not exported by default.
155              
156             =back
157              
158             Now, why would you want to stuff these "delegted" methods into attributes?
159             Why not just write them as regular methods?
160              
161             sub is_in_progress {
162             my $self = shift;
163             $self->status eq 'in progress';
164             }
165              
166             A good question. Writing methods which are closely associated with a
167             single attribute as delegated methods just seems to me to be a nice
168             way of grouping related methods. You can even use it for builders:
169              
170             has user_agent => (
171             is => 'ro',
172             isa => 'Object',
173             lazy_build => 1,
174             handles => {
175             get => 'get',
176             _build_user_agent => sub { LWP::UserAgent->new },
177             },
178             );
179              
180             =head1 EXPORT
181              
182             This module uses L<Sub::Exporter> so it's possible to rename exported
183             functions:
184              
185             use MooseX::NiftyDelegation
186             Nifty => {},
187             value_is => { -as => 'value_is_exactly' },
188             value_like => { -as => 'value_matches' },
189             ;
190              
191             See L<Sub::Exporter> for further details.
192              
193             =head1 CAVEATS
194              
195             =over
196              
197             =item *
198              
199             Using a coderef in the delegation hashref is not documented, it's not
200             tested for, and Jesse Luehrs says he doesn't like it. So the feature
201             could get removed at any point.
202              
203             In that case, I'll need to update this module with a bunch of extra
204             metahackery. I'm 95% sure it would still be doable - just a lot more
205             code.
206              
207             =item *
208              
209             This module doesn't work in conjunction with attribute native traits.
210             This is native traits insists that the delegated method is either a
211             string or arrayref.
212              
213             Patches to get this working with native traits are welcome.
214              
215             =back
216              
217             =head1 BUGS
218              
219             Please report any bugs to
220             L<http://rt.cpan.org/Dist/Display.html?Queue=MooseX-NiftyDelegation>.
221              
222             =head1 SEE ALSO
223              
224             L<Moose::Manual::Delegation>.
225              
226             =head1 AUTHOR
227              
228             Toby Inkster E<lt>tobyink@cpan.orgE<gt>.
229              
230             =head1 COPYRIGHT AND LICENCE
231              
232             This software is copyright (c) 2012 by Toby Inkster.
233              
234             This is free software; you can redistribute it and/or modify it under
235             the same terms as the Perl 5 programming language system itself.
236              
237             =head1 DISCLAIMER OF WARRANTIES
238              
239             THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
240             WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
241             MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
242