File Coverage

blib/lib/MooX/PluginKit/Consumer.pm
Criterion Covered Total %
statement 115 135 85.1
branch 37 52 71.1
condition 16 24 66.6
subroutine 29 32 90.6
pod 3 3 100.0
total 200 246 81.3


line stmt bran cond sub pod time code
1             package MooX::PluginKit::Consumer;
2              
3             $MooX::PluginKit::Consumer::VERSION = '0.04';
4              
5             =head1 NAME
6              
7             MooX::PluginKit::Consumer - Declare a class as a consumer of
8             PluginKit plugins.
9              
10             =head1 SYNOPSIS
11              
12             package My::Class;
13             use Moo;
14             use MooX::PluginKit::Consumer;
15            
16             # Optional, defaults to just 'My::Class'.
17             plugin_namespace 'My::Class::Plugin';
18            
19             has_pluggable_object some_object => (
20             class => 'Some::Object',
21             );
22            
23             my $object = My::Class->new(
24             plugins => [...],
25             some_object=>{...},
26             );
27              
28             =head1 DESCRIPTION
29              
30             This module, when Cd, sets the callers base class to the
31             L class, applies the
32             L role to the caller, and
33             exports several candy functions (see L) into the
34             caller.
35              
36             Some higher-level documentation about how to consume plugins can
37             be found at L.
38              
39             =cut
40              
41 3     3   665962 use MooX::PluginKit::Core;
  3         9  
  3         266  
42 3     3   1228 use MooX::PluginKit::ConsumerRole;
  3         9  
  3         103  
43 3     3   20 use Types::Standard -types;
  3         5  
  3         21  
44 3     3   11193 use Types::Common::String -types;
  3         6  
  3         21  
45 3     3   4993 use Class::Method::Modifiers qw( install_modifier );
  3         3837  
  3         207  
46 3     3   23 use Module::Runtime qw( require_module );
  3         7  
  3         35  
47 3     3   130 use Scalar::Util qw( blessed );
  3         5  
  3         124  
48 3     3   20 use Carp qw( croak );
  3         7  
  3         100  
49 3     3   13 use Exporter qw();
  3         5  
  3         50  
50              
51 3     3   12 use strictures 2;
  3         22  
  3         112  
52 3     3   578 use namespace::clean;
  3         6  
  3         21  
53              
54             our @EXPORT = qw(
55             plugin_namespace
56             has_pluggable_object
57             has_pluggable_class
58             );
59              
60             sub import {
61             {
62 12     12   4765 my $caller = (caller())[0];
  12         43  
63 12         49 init_consumer( $caller );
64 12         30 get_consumer_moo_extends( $caller )->('MooX::PluginKit::ConsumerBase');
65 12         5654 get_consumer_moo_with( $caller )->('MooX::PluginKit::ConsumerRole');
66             }
67              
68 12         11816 goto &Exporter::import;
69             }
70              
71             =head1 CANDY
72              
73             =head2 plugin_namespace
74              
75             plugin_namespace 'Location::Of::My::Plugins';
76              
77             When the L argument is set
78             the user may choose to pass relative plugins. Setting this namespace
79             changes the default root namespace used to resolve these relative
80             plugin names to absolute ones.
81              
82             This defaults to the package name of the class which uses this module.
83              
84             Read more about this at L.
85              
86             =cut
87              
88             sub plugin_namespace {
89 1     1 1 82 my ($consumer) = caller();
90 1         5 local $Carp::Internal{ (__PACKAGE__) } = 1;
91 1         7 set_consumer_namespace( $consumer, @_ );
92 1         3 return;
93             }
94              
95             =head2 has_pluggable_object
96              
97             has_pluggable_object foo_bar => (
98             class => 'Foo::Bar',
99             );
100              
101             This function acts like L but adds a bunch of functionality,
102             making it easy to cascade the creation of objects which automatically
103             have applicable plugins applied to them, at run-time.
104              
105             In the above C example, the user of your class can then specify
106             the C argument as a hashref. This hashref will be used to
107             create an object of the C class, but not until after any
108             applicable plugins set on the consumer class have been applied to it.
109              
110             Documented below are the L argument which are supported as well
111             as several custom arguments (like C, above).
112              
113             Note that you MUST set either L, L, or L.
114              
115             Read more about this at L.
116              
117             =head3 Moo Arguments
118              
119             This function only supports a subset of the arguments that L
120             supports. They are:
121              
122             builder
123             default
124             handles
125             init_arg
126             isa
127             required
128             weak_ref
129              
130             =head3 class
131              
132             Setting this to a class name does two things, 1) it declares the C on
133             the attributes to validate that the final value is an instance of the class
134             or a subclass of it, and 2) sets L to it.
135              
136             =head3 default_class
137              
138             If no class is specified this will be the default class used. A common idiom
139             of using both L and this is:
140              
141             has_pluggable_object foo => (
142             class => 'Foo',
143             default_class => 'Foo::SubClass',
144             );
145              
146             Meaning, in the above example, that the final object may be any subclass of the
147             C class, but if no class is specified, it will be constructed from the
148             C class.
149              
150             =head3 class_arg
151              
152             If the class to be instantiated can be derived from the hashref argument to
153             this attribute then set this to the name of the key in the hashref to get the
154             class from. Setting this to a C<1> is the same as setting it to C. So,
155             these are the same:
156              
157             has_pluggable_object foo => ( class_arg=>1 );
158             has_pluggable_object foo => ( class_arg=>'class' );
159              
160             Then when passing the hashref the class can be declared as part of it:
161              
162             my $thing = YourClass->new( foo=>{ class=>'Foo::Stuff', ... } );
163              
164             =head3 class_builder
165              
166             Set this to a method name or a code ref which will be used to build the
167             class name. This sub will be called as a method and passed the args hashref
168             and is expected to return a class name.
169              
170             If this is set to C<1> then the method name will be automatically generated
171             based on the attribute name. So, these are identical:
172              
173             has_pluggable_object foo => ( class_builder=>1 );
174             has_pluggable_object foo => ( class_builder=>'_foo_build_class' );
175              
176             Then make the sub:
177              
178             sub _foo_build_class { my ($self, $args) = @_; ...; return $class }
179              
180             Note that the class builder will not be called if L if set and
181             the user has specified a class argument.
182              
183             =head3 class_namespace
184              
185             Set this to allow the class to be relative. This way if the class starts with
186             C<::> then this namespace will be automatically prefixed to it.
187              
188             =head3 args_builder
189              
190             Set this to a method name or a code ref which will be used to adjust the
191             hashref arguments before the object is constructed from them. This sub will
192             be called as a method and passed the args hashref and is epxected to return
193             an args hashref.
194              
195             If this is set to C<1> then the method name will be automatically generated
196             based on the attribute name. So, these are identical:
197              
198             has_pluggable_object foo => ( args_builder=>1 );
199             has_pluggable_object foo => ( args_builder=>'_foo_build_args' );
200              
201             Then make the sub:
202              
203             sub _foo_build_args { my ($self, $args) = @_; ...; return $args }
204              
205             =cut
206              
207             sub has_pluggable_object {
208 9     9 1 69710 my ($name, %args) = @_;
209 9         48 my $consumer_class = (caller())[0];
210 9         38 local $Carp::Internal{ (__PACKAGE__) } = 1;
211              
212 9         40 my $has = get_consumer_moo_has( $consumer_class );
213              
214 9         32 my $class_builder = _normalize_class_builder( $name, $consumer_class, %args );
215 9         46 my $args_builder = _normalize_args_builder( $name, $consumer_class, %args );
216              
217 9         20 my $isa = delete $args{isa};
218 9         17 my $class = delete $args{class};
219              
220 9 50       19 if (!defined $isa) {
221 9 100       38 $isa = InstanceOf[ $class ] if defined $class;
222 9   66     3332 $isa ||= Object;
223             }
224              
225 9         92 my $init_name = "_init_$name";
226 9         41 my $init_isa = $isa | HashRef;
227              
228             $has->(
229             $init_name,
230             init_arg => $name,
231             is => 'ro',
232             isa => $init_isa,
233             lazy => 1,
234             (
235 0         0 map { $_ => $args{$_} }
236 9         3963 grep { exists $args{$_} }
  45         96  
237             qw( default builder required weak_ref init_arg )
238             ),
239             );
240              
241 9         5417 my $attr_isa = $isa;
242 9 50       49 $attr_isa = $attr_isa | Undef if !$args{required};
243              
244             $has->(
245             $name,
246             init_arg => undef,
247             is => 'lazy',
248             isa => $attr_isa,
249             (
250 0         0 map { $_ => $args{$_} }
251 9         1022 grep { exists $args{$_} }
  18         50  
252             qw( handles weak_ref )
253             ),
254             builder => _build_attr_builder(
255             $init_name, $args_builder, $class_builder,
256             ),
257             );
258              
259 9         19762 return;
260             }
261              
262             # Avoid circular references by making this anonymous sub into a separate closure.
263             sub _build_attr_builder {
264 9     9   22 my ($init_name, $args_builder, $class_builder) = @_;
265              
266             return sub{
267 9     9   532 my ($self) = @_;
        9      
        9      
        9      
        9      
        9      
        9      
        9      
        9      
        9      
268              
269 9         30 my $args = $self->$init_name();
270 9 50       31 return $args if ref($args) ne 'HASH';
271 9 100       36 $args = $self->$args_builder({ %$args }) if defined $args_builder;
272              
273 9         160 my $class = $self->$class_builder( $args );
274              
275 9         35 return $self->class_new_with_plugins(
276             $class, $args,
277             );
278 9         46 };
279             }
280              
281             sub _normalize_class_builder {
282 9     9   27 my ($name, $consumer_class, %args) = @_;
283              
284 9         23 my $class = delete $args{class};
285 9         17 my $default_class = delete $args{default_class};
286 9         20 my $class_arg = delete $args{class_arg};
287 9         17 my $class_builder = delete $args{class_builder};
288 9         16 my $class_namespace = delete $args{class_namespace};
289              
290 9 50       29 $default_class = $class if !defined $default_class;
291 9 50 66     36 $class_arg = undef if defined($class_arg) and "$class_arg" eq '0';
292 9 50 66     35 $class_builder = undef if defined($class_builder) and "$class_builder" eq '0';
293              
294 9 100 100     38 $class_arg = 'class' if defined($class_arg) and "$class_arg" eq '1';
295              
296 9         16 my $class_builder_sub;
297 9 100       30 if (ref($class_builder) eq 'CODE') {
    100          
298 1         3 $class_builder_sub = $class_builder;
299 1         2 $class_builder = 1;
300             }
301             elsif (!defined $class_builder) {
302 6     4   21 $class_builder_sub = sub{ undef };
  4         16  
303 6         12 $class_builder = 1;
304             }
305              
306 9 100 66     55 if (defined($class_builder) and "$class_builder" eq '1') {
307 8         18 $class_builder = $name . '_build_class';
308 8 50       33 $class_builder = '_' . $class_builder if $class_builder !~ m{^_};
309             }
310              
311 9 100       24 if ($class_builder_sub) {
312 7         25 install_modifier(
313             $consumer_class, 'fresh',
314             $class_builder => $class_builder_sub,
315             );
316             }
317              
318             install_modifier(
319             $consumer_class, 'around',
320             $class_builder => sub{
321 9     9   180 my ($orig, $self, $args) = @_;
322              
323 9 100       26 my $class = defined($class_arg) ? $args->{$class_arg} : undef;
324 9 100       78 $class = $self->$orig( $args ) if !defined $class;
325 9 100       28 $class = $default_class if !defined $class;
326 9 50       22 return undef if !defined $class;
327              
328 9 50       24 $class = $class_namespace . $class if $class =~ m{^::};
329 9         18 return $class;
330             },
331 9         1211 );
332              
333 9         2671 return $class_builder;
334             }
335              
336             sub _normalize_args_builder {
337 9     9   36 my ($name, $consumer_class, %args) = @_;
338              
339 9         23 my $args_builder = delete $args{args_builder};
340              
341 9 50 66     39 $args_builder = undef if defined($args_builder) and "$args_builder" eq '0';
342              
343 9         13 my $args_builder_sub;
344              
345 9 100       26 if (ref($args_builder) eq 'CODE') {
346 1         2 $args_builder_sub = $args_builder;
347 1         2 $args_builder = 1;
348             }
349              
350 9 100 100     31 if (defined($args_builder) and "$args_builder" eq '1') {
351 2         5 $args_builder = $name . '_build_args';
352 2 50       10 $args_builder = '_' . $args_builder if $args_builder !~ m{^_};
353             }
354              
355 9 100       22 if ($args_builder_sub) {
356 1         3 install_modifier(
357             $consumer_class, 'fresh',
358             $args_builder => $args_builder_sub,
359             );
360             }
361              
362 9         57 return $args_builder;
363             }
364              
365             =head2 has_pluggable_class
366              
367             has_pluggable_class foo_bar_class => (
368             default => 'Foo::Bar',
369             );
370              
371             This function acts like L but adds a bunch of functionality,
372             making it easy to refer to a class that gets plugins applied to it
373             at run-time.
374              
375             In the above C example, the user of your class can then specify
376             the C argument, if they wish, and the class they pass in will
377             have any relevant plugins applied to it.
378              
379             This function only supports a subset of the arguments that L
380             supports. They are:
381              
382             builder
383             default
384             init_arg
385             isa
386             required
387              
388             =cut
389              
390             sub has_pluggable_class {
391 0     0 1   my ($name, %args) = @_;
392 0           my $consumer_class = (caller())[0];
393 0           local $Carp::Internal{ (__PACKAGE__) } = 1;
394              
395 0           my $has = get_consumer_moo_has( $consumer_class );
396              
397 0           my $init_name = "_init_$name";
398              
399             $has->(
400             $init_name,
401             init_arg => $name,
402             is => 'ro',
403             isa => NonEmptySimpleStr,
404             lazy => 1,
405             (
406 0           map { $_ => $args{$_} }
407 0           grep { exists $args{$_} }
  0            
408             qw( default builder required init_arg )
409             ),
410             );
411              
412 0   0       my $isa = $args{isa} || ClassName;
413 0 0         $isa = $isa | Undef if !$args{required};
414              
415 0           $has->(
416             $name,
417             init_arg => undef,
418             is => 'lazy',
419             isa => $isa,
420             builder => _build_class_attr_builder(
421             $init_name,
422             ),
423             );
424              
425 0           return;
426             }
427              
428             sub _build_class_attr_builder {
429 0     0     my ($init_name) = @_;
430              
431             return sub{
432 0     0     my ($self) = @_;
433              
434 0           my $class = $self->$init_name();
435              
436 0 0         require_module $class if !$class->can('new');
437              
438 0           return $self->plugin_factory->build_class( $class );
439 0           };
440             }
441              
442             1;
443             __END__