File Coverage

blib/lib/Curio/Factory.pm
Criterion Covered Total %
statement 177 197 89.8
branch 60 94 63.8
condition 4 9 44.4
subroutine 52 57 91.2
pod 13 14 92.8
total 306 371 82.4


line stmt bran cond sub pod time code
1             package Curio::Factory;
2             our $VERSION = '0.10';
3              
4             =encoding utf8
5              
6             =head1 NAME
7              
8             Curio::Factory - Definer, creator, provider, and holder of Curio objects.
9              
10             =head1 SYNOPSIS
11              
12             my $factory = MyApp::Service::Cache->factory();
13              
14             =head1 DESCRIPTION
15              
16             The factory object contains the vast majority of Curio's logic.
17             Each Curio class (L classes who consume L) gets
18             a single factory object created for them via L.
19              
20             Note that much of the example code in this documentation is based
21             on the L. Also when you see the term "Curio
22             object" it is referring to instances of L.
23              
24             =cut
25              
26 11     11   452131 use Curio::Guard;
  11         29  
  11         317  
27 11     11   848 use Curio::Util;
  11         20  
  11         518  
28 11     11   67 use Package::Stash;
  11         19  
  11         253  
29 11     11   55 use Scalar::Util qw( blessed refaddr );
  11         24  
  11         577  
30 11     11   5577 use Types::Common::String qw( NonEmptySimpleStr );
  11         1006265  
  11         162  
31 11     11   6062 use Types::Standard qw( Bool Map HashRef Undef );
  11         29  
  11         69  
32              
33 11     11   17787 use Moo;
  11         78529  
  11         61  
34 11     11   16299 use strictures 2;
  11         105  
  11         533  
35 11     11   2388 use namespace::clean;
  11         25  
  11         99  
36              
37             my %class_to_factory;
38              
39             my $undef_key = '__UNDEF_KEY__';
40              
41             sub BUILD {
42 40     40 0 5240 my ($self) = @_;
43              
44 40         123 $self->_store_class_to_factory();
45 39         103 $self->_install_fetch_method();
46 39         127 $self->_install_factory_method();
47              
48 39         146 return;
49             }
50              
51             sub _store_class_to_factory {
52 40     40   86 my ($self) = @_;
53              
54 40         155 my $class = $self->class();
55              
56             croak "Class already has a Curio::Factory object: $class"
57 40 100       129 if $class_to_factory{ $class };
58              
59 39         76 $class_to_factory{ $class } = $self;
60              
61 39         73 return;
62             }
63              
64             sub _install_fetch_method {
65 39     39   65 my ($self) = @_;
66              
67             Package::Stash->new( $self->class() )->add_symbol(
68             '&fetch',
69             subname(
70             'fetch',
71             sub{
72 43     43   14371 shift;
        43      
        40      
        38      
        26      
        10      
        10      
73 43         127 return $self->fetch_curio( @_ );
74             },
75 39         921 ),
76             );
77              
78 39         139 return;
79             }
80              
81             sub _install_factory_method {
82 39     39   85 my ($self) = @_;
83              
84             Package::Stash->new( $self->class() )->add_symbol(
85             '&factory',
86             subname(
87             'factory',
88 114     114   1587 sub{ $self },
        114      
        109      
        81      
        65      
        28      
        28      
89 39         522 ),
90             );
91              
92 39         99 return;
93             }
94              
95             sub _process_key_arg {
96 75     75   207 my ($self, $args) = @_;
97              
98 75         422 my $caller_sub_name = (caller 1)[3];
99 75         474 $caller_sub_name =~ s{^.*::}{};
100              
101 75         138 my $key;
102              
103 75 100       956 if (@$args) {
    100          
104 36         75 $key = shift @$args;
105 36 100       108 croak "Invalid key passed to $caller_sub_name()"
106             if !NonEmptySimpleStr->check( $key );
107             }
108             elsif (defined $self->default_key()) {
109 35         745 $key = $self->default_key();
110             }
111             else {
112 4         57 croak "No key was passed to $caller_sub_name()";
113             }
114              
115             $key = $self->_aliases->{$key}
116             if defined( $key )
117 69 100 66     1252 and defined( $self->_aliases->{$key} );
118              
119 69 100       1436 if (!$self->allow_undeclared_keys()) {
120             croak "Undeclared key passed to $caller_sub_name()"
121 47 100       442 if !$self->_keys->{$key};
122             }
123              
124 66         261 return $key;
125             }
126              
127             has _cache => (
128             is => 'ro',
129             init_arg => undef,
130             default => sub{ {} },
131             );
132              
133             sub _cache_set {
134 5     5   47 my ($self, $key, $curio) = @_;
135 5         12 $key = $self->_fixup_cache_key( $key );
136 5         43 $self->_cache->{$key} = $curio;
137 5         10 return;
138             }
139              
140             sub _cache_get {
141 8     8   100 my ($self, $key) = @_;
142 8         22 $key = $self->_fixup_cache_key( $key );
143 8         71 return $self->_cache->{$key};
144             }
145              
146             sub _fixup_cache_key {
147 15     15   25 my ($self, $key) = @_;
148              
149 15 100       44 $key = $undef_key if !defined $key;
150 15 100       248 return $key if !$self->cache_per_process();
151              
152 1         8 $key .= "-$$";
153 1 50       10 $key .= '-' . threads->tid() if $INC{'threads.pm'};
154              
155 1         5 return $key;
156             }
157              
158             has _registry => (
159             is => 'ro',
160             init_arg => undef,
161             default => sub{ {} },
162             );
163              
164             has _keys => (
165             is => 'ro',
166             init_arg => undef,
167             default => sub{ {} },
168             );
169              
170             has _aliases => (
171             is => 'ro',
172             init_arg => undef,
173             default => sub{ {} },
174             );
175              
176             has _injections => (
177             is => 'ro',
178             init_arg => undef,
179             default => sub{ {} },
180             );
181              
182             sub _set_injection {
183 3     3   8 my ($self, $key, $curio) = @_;
184 3         6 $key = $self->_fixup_injection_key( $key );
185 3         9 $self->_injections->{$key} = $curio;
186 3         6 return;
187             }
188              
189             sub _get_injection {
190 57     57   111 my ($self, $key) = @_;
191 57         127 $key = $self->_fixup_injection_key( $key );
192 57         193 return $self->_injections->{$key};
193             }
194              
195             sub _remove_injection {
196 3     3   6 my ($self, $key) = @_;
197 3         6 $key = $self->_fixup_injection_key( $key );
198 3         10 my $curio = delete $self->_injections->{$key};
199 3         5 return $curio;
200             }
201              
202             sub _fixup_injection_key {
203 63     63   105 my ($self, $key) = @_;
204 63 50       136 $key = $undef_key if !defined $key;
205 63         117 return $key;
206             }
207              
208             =head1 REQUIRED ARGUMENTS
209              
210             =head2 class
211              
212             class => 'MyApp::Service::Cache',
213              
214             The Curio class that this factory uses to instantiate Curio
215             objects.
216              
217             This is automatically set by L.
218              
219             =cut
220              
221             has class => (
222             is => 'ro',
223             isa => NonEmptySimpleStr,
224             required => 1,
225             );
226              
227             =head1 OPTIONAL ARGUMENTS
228              
229             =head2 does_registry
230              
231             does_registry => 1,
232             resource_method_name => 'chi',
233              
234             Causes the resource of all Curio objects to be automatically
235             registered so that L may function.
236              
237             Defaults off (C<0>), meaning L will always return
238             C.
239              
240             =cut
241              
242             has does_registry => (
243             is => 'rw',
244             isa => Bool,
245             default => 0,
246             );
247              
248             =head2 resource_method_name
249              
250             resource_method_name => 'chi',
251              
252             The method name in the Curio class to retrieve the resource that
253             it holds. A resource is whatever "thing" the Curio class
254             encapsulates. In the case of the example in L the
255             resource is the CHI object which is accessible via the C
256             method.
257              
258             It is still your job to create the method in the Curio class that
259             this argument refers to, such as:
260              
261             has chi => ( is=>'lazy', ... );
262              
263             This argument must be defined in order for L and
264             L to work, otherwise they will have no way
265             to know how to get at the resource object.
266              
267             This defaults to the string C.
268              
269             =cut
270              
271             has resource_method_name => (
272             is => 'rw',
273             isa => NonEmptySimpleStr,
274             default => 'resource',
275             );
276              
277             =head2 installs_curio_method
278              
279             does_registry => 1,
280             resource_method_name => 'chi',
281             installs_curio_method => 1,
282              
283             This causes a C method to be installed in all resource
284             object classes. The method calls L and returns it,
285             allowing for reverse lookups from resource objects to curio objects.
286              
287             L must be set for this to function.
288              
289             =cut
290              
291             has installs_curio_method => (
292             is => 'rw',
293             isa => Bool,
294             default => 0,
295             );
296              
297             =head2 does_caching
298              
299             does_caching => 1,
300              
301             When caching is enabled all calls to L will attempt to
302             retrieve from an in-memory cache.
303              
304             Defaults off (C<0>), meaning all fetch calls will return a new
305             Curio object.
306              
307             =cut
308              
309             has does_caching => (
310             is => 'rw',
311             isa => Bool,
312             default => 0,
313             );
314              
315             =head2 cache_per_process
316              
317             cache_per_process 1,
318              
319             Some resource objects do not like to be created in one process
320             and then used in others. When enabled this will add the current
321             process's PID and thread ID (if threads are enabled) to the key
322             used to cache the Curio object.
323              
324             If either of these process IDs change then fetch will not re-use
325             the cached Curio object from a different process and will create
326             a new Curio object under the new process IDs.
327              
328             Defaults to off (C<0>), meaning the same Curio objects will be
329             used by fetch across all forks and threads.
330              
331             Normally the default works fine. Some L drivers need
332             this turned on.
333              
334             =cut
335              
336             has cache_per_process => (
337             is => 'rw',
338             isa => Bool,
339             default => 0,
340             );
341              
342             =head2 export_function_name
343              
344             export_function_name => 'myapp_cache',
345              
346             The export function is exported when the the Curio class is
347             imported, as in:
348              
349             use MyApp::Service::Cache;
350             my $chi = myapp_cache( $key );
351              
352             See also L and L.
353              
354             =cut
355              
356             has export_function_name => (
357             is => 'rw',
358             isa => NonEmptySimpleStr | Undef,
359             );
360              
361             =head2 always_export
362              
363             always_export => 1,
364              
365             When enabled this causes the export function to be always exported.
366              
367             use MyApp::Service::Cache;
368              
369             When this option is not set you must explicitly request that the
370             export function be exported.
371              
372             use MyApp::Service::Cache qw( myapp_cache );
373              
374             =cut
375              
376             has always_export => (
377             is => 'rw',
378             isa => Bool,
379             default => 0,
380             );
381              
382             =head2 export_resource
383              
384             export_resource => 1,
385              
386             Rather than returning the curio object this will cause the resource
387             object to be returned by the export function. Requires that
388             L be set.
389              
390             =cut
391              
392             has export_resource => (
393             is => 'rw',
394             isa => Bool,
395             default => 0,
396             );
397              
398             =head2 allow_undeclared_keys
399              
400             allow_undeclared_keys => 1,
401              
402             When L, and other key-accepting methods are called, they
403             normally throw an exception if the passed key has not already been
404             declared with L. By allowing undeclared keys any key
405             may be passed, which can be useful especially if coupled with
406             L.
407              
408             Defaults to off (C<0>), meaning keys must always be declared before
409             being used.
410              
411             =cut
412              
413             has allow_undeclared_keys => (
414             is => 'rw',
415             isa => Bool,
416             default => 0,
417             );
418              
419             =head2 default_key
420              
421             default_key => 'generic',
422              
423             If no key is passed to key-accepting methods like L then
424             they will use this default key if available.
425              
426             Defaults to no default key.
427              
428             =cut
429              
430             has default_key => (
431             is => 'rw',
432             isa => NonEmptySimpleStr | Undef,
433             );
434              
435             =head2 key_argument
436              
437             key_argument => 'connection_key',
438              
439             When set, this causes an extra argument to be passed to the Curio
440             class during object instantiation. The argument's key will be
441             whatever you set C to and the value will be the
442             key used to fetch the Curio object.
443              
444             You will still need to write the code in your Curio class to
445             capture the argument, such as:
446              
447             has connection_key => ( is=>'ro' );
448              
449             Defaults to no key argument.
450              
451             =cut
452              
453             has key_argument => (
454             is => 'rw',
455             isa => NonEmptySimpleStr | Undef,
456             );
457              
458             =head2 default_arguments
459              
460             default_arguments => {
461             arg => 'value',
462             ...
463             },
464              
465             When set, these arguments will be used when creating new instances
466             of the Curio class.
467              
468             Any other arguments such as those provided by L and
469             L will overwrite these default arguments.
470              
471             =cut
472              
473             has default_arguments => (
474             is => 'rw',
475             isa => HashRef,
476             default => sub{ {} },
477             );
478              
479             =head1 ATTRIBUTES
480              
481             =head2 declared_keys
482              
483             my $keys = $factory->declared_keys();
484             foreach my $key (@$keys) { ... }
485              
486             Returns an array ref containing all the keys declared with
487             L.
488              
489             =cut
490              
491             sub declared_keys {
492 0     0 1 0 my ($self) = @_;
493 0         0 return [ keys %{ $self->_keys() } ];
  0         0  
494             }
495              
496             =head1 METHODS
497              
498             =head2 fetch_curio
499              
500             my $curio = $factory->fetch_curio();
501             my $curio = $factory->fetch_curio( $key );
502              
503             Returns a Curio object. If L is enabled then
504             a cached object may be returned.
505              
506             =cut
507              
508             sub fetch_curio {
509 46     46 1 82 my $self = shift;
510 46         144 my $key = $self->_process_key_arg( \@_ );
511 41 50       112 croak 'Too many arguments passed to fetch_curio()' if @_;
512              
513 41         146 return $self->_fetch_curio( $key );
514             }
515              
516             sub _fetch_curio {
517 48     48   98 my ($self, $key) = @_;
518              
519 48         73 my $curio;
520              
521 48         101 $curio = $self->_get_injection( $key );
522 48 100       130 return $curio if $curio;
523              
524 45 100       795 $curio = $self->_cache_get( $key ) if $self->does_caching();
525 45 100       292 return $curio if $curio;
526              
527 42         131 $curio = $self->_create( $key, {} );
528              
529 42 100       702 $self->_cache_set( $key, $curio ) if $self->does_caching();
530              
531 42         336 return $curio;
532             }
533              
534             =head2 fetch_resource
535              
536             my $resource = $factory->fetch_resource();
537             my $resource = $factory->fetch_resource( $key );
538              
539             Like L, but always returns a resource.
540              
541             =cut
542              
543             sub fetch_resource {
544 7     7 1 18 my $self = shift;
545 7         27 my $key = $self->_process_key_arg( \@_ );
546 7 50       20 croak 'Too many arguments passed to fetch_resource()' if @_;
547              
548 7         21 return $self->_fetch_resource( $key );
549             }
550              
551             sub _fetch_resource {
552 7     7   19 my ($self, $key) = @_;
553              
554 7         120 my $method = $self->resource_method_name();
555              
556 7         59 my $curio = $self->_fetch_curio( $key );
557 7 100       44 return undef if !$curio->can( $method );
558              
559 5         87 return $curio->$method();
560             }
561              
562             =head2 create
563              
564             my $curio = $factory->create( %extra_args );
565             my $curio = $factory->create( $key, %extra_args );
566              
567             Creates a new curio object with arguments gotten from L. Extra
568             arguments, which will take precedence, may also be passed.
569              
570             =cut
571              
572             sub create {
573 0     0 1 0 my $self = shift;
574 0         0 my $key = $self->_process_key_arg( \@_ );
575              
576 0         0 my $extra_args = $self->class->BUILDARGS( @_ );
577              
578 0         0 return $self->_create( $key, $extra_args );
579             }
580              
581             sub _create {
582 42     42   93 my ($self, $key, $extra_args) = @_;
583              
584 42         101 my $args = $self->_arguments( $key );
585              
586 42         372 my $curio = $self->class->new(
587             %$args,
588             %$extra_args,
589             );
590              
591 42         11212 my $method = $self->resource_method_name();
592 42 100       399 if ($curio->can($method)) {
593 6         26 my $resource = $curio->$method();
594 6         44 $self->_register_resource( $curio, $resource );
595              
596 6         52 my $resource_class = blessed $resource;
597 6 50       22 $self->_install_curio_method( $resource_class ) if $resource_class;
598             }
599              
600 42         122 return $curio;
601             }
602              
603             sub _register_resource {
604 6     6   16 my ($self, $curio, $resource) = @_;
605              
606 6 100       112 return if !$self->does_registry();
607 1 50       13 return if !ref $resource;
608              
609 1         6 $self->_registry->{ refaddr $resource } = $curio;
610              
611 1         2 return;
612             }
613              
614             sub _install_curio_method {
615 0     0   0 my ($self, $resource_class) = @_;
616              
617 0 0       0 return if !$self->installs_curio_method();
618 0 0       0 return if $resource_class->can('curio');
619              
620 11     11   25461 no strict 'refs';
  11         35  
  11         10976  
621              
622 0         0 *{"$resource_class\::curio"} = sub{
623 0     0   0 my ($resource) = @_;
624 0 0       0 return undef if !blessed $resource;
625 0         0 return $self->find_curio( $resource );
626 0         0 };
627              
628 0         0 return;
629             }
630              
631             =head2 arguments
632              
633             my $args = $factory->arguments();
634             my $args = $factory->arguments( $key );
635              
636             This method returns an arguments hashref that would be used to
637             instantiate a new Curio object. You could, for example, use this
638             to produce a base-line set of arguments, then sprinkle in some
639             more, and make yourself a special mock object to be injected.
640              
641             =cut
642              
643             sub arguments {
644 3     3 1 6 my $self = shift;
645 3         12 my $key = $self->_process_key_arg( \@_ );
646 3 50       8 croak 'Too many arguments passed to arguments()' if @_;
647              
648 3         8 return $self->_arguments( $key );
649             }
650              
651             sub _arguments {
652 45     45   89 my ($self, $key) = @_;
653              
654 45         72 my $args = { %{ $self->default_arguments() } };
  45         788  
655              
656 45 50       347 return $args if !defined $key;
657              
658             %$args = (
659             %$args,
660 45 100       86 %{ $self->_keys->{$key} || {} },
  45         231  
661             );
662              
663 45 100       860 if (defined $self->key_argument()) {
664 5         103 $args->{ $self->key_argument() } = $key;
665             }
666              
667 45         340 return $args;
668             }
669              
670             =head2 add_key
671              
672             $factory->add_key( $key, %arguments );
673              
674             Declares a new key.
675              
676             Arguments are optional, but if present they will be saved and used
677             by L when calling C on L.
678              
679             =cut
680              
681             sub add_key {
682 28     28 1 79 my ($self, $key, @args) = @_;
683              
684 28 50       96 croakf(
685             'Invalid key passed to add_key(): %s',
686             NonEmptySimpleStr->get_message( $key ),
687             ) if !NonEmptySimpleStr->check( $key );
688              
689             croak "Already declared key passed to add_key(): $key"
690 28 50       933 if $self->_keys->{$key};
691              
692 28 50       110 croak 'Odd number of key arguments passed to add_key()'
693             if @args % 2 != 0;
694              
695 28         99 $self->_keys->{$key} = { @args };
696              
697 28         95 return;
698             }
699              
700             =head2 alias_key
701              
702             $factory->alias_key( $alias_key => $real_key );
703              
704             Adds a key that is an alias to a key that was declared with
705             L. Alias keys can be used anywhere a declared key
706             can be used.
707              
708             =cut
709              
710             sub alias_key {
711 1     1 1 4 my ($self, $alias, $key) = @_;
712              
713 1 50       4 croakf(
714             'Invalid alias passed to alias_key(): %s',
715             NonEmptySimpleStr->get_message( $alias ),
716             ) if !NonEmptySimpleStr->check( $alias );
717              
718 1 50       25 croakf(
719             'Invalid key passed to alias_key(): %s',
720             NonEmptySimpleStr->get_message( $key ),
721             ) if !NonEmptySimpleStr->check( $key );
722              
723             croak "Already declared alias passed to alias_key(): $alias"
724 1 50       22 if defined $self->_aliases->{$alias};
725              
726             croak "Undeclared key passed to alias_key(): $key"
727 1 50 33     30 if !$self->allow_undeclared_keys() and !$self->_keys->{$key};
728              
729 1         24 $self->_aliases->{$alias} = $key;
730              
731 1         4 return;
732             }
733              
734             =head2 find_curio
735              
736             my $curio_object = $factory->find_curio( $resource );
737              
738             Given a Curio object's resource this will return that Curio
739             object for it.
740              
741             This does a reverse lookup of sorts and can be useful in
742             specialized situations where you have the resource, and you
743             need to introspect back into the Curio object.
744              
745             # I have my $chi and nothing else.
746             my $factory = MyApp::Service::Cache->factory();
747             my $curio = $factory->find_curio( $chi );
748              
749             This only works if you've enabled L, otherwise
750             C is always returned by this method.
751              
752             =cut
753              
754             sub find_curio {
755 2     2 1 6 my ($self, $resource) = @_;
756              
757 2 50       6 croak 'Non-reference resource passed to find_curio()'
758             if !ref $resource;
759              
760 2         16 return $self->_registry->{ refaddr $resource };
761             }
762              
763             =head2 inject
764              
765             $factory->inject( $curio_object );
766             $factory->inject( $key, $curio_object );
767              
768             Takes a curio object of your making and forces L to
769             return the injected object (or the injected object's resource).
770             This is useful for injecting mock objects in tests.
771              
772             The L method is a good way to make the mock curio object.
773              
774             =cut
775              
776             sub inject {
777 3     3 1 6 my $self = shift;
778 3 50 33     29 my $object = (@_>0 and @_<3 and blessed($_[@_-1])) ? pop() : undef;
779 3 50       10 croak 'No object passed to inject()' if !$object;
780 3         10 my $key = $self->_process_key_arg( \@_ );
781              
782 3 50       9 $key = $undef_key if !defined $key;
783              
784 3 50       19 croak 'Cannot inject a Curio object where one has already been injected'
785             if $self->_get_injection( $key );
786              
787 3         9 $self->_set_injection( $key, $object );
788              
789 3         7 return;
790             }
791              
792             =head2 inject_with_guard
793              
794             my $guard = $factory->inject_with_guard(
795             $curio_object,
796             );
797            
798             my $guard = $factory->inject_with_guard(
799             $key, $curio_object,
800             );
801              
802             This is just like L except it returns an guard object which,
803             when it leaves scope and is destroyed, will automatically
804             L.
805              
806             =cut
807              
808             sub inject_with_guard {
809 1     1 1 2 my $self = shift;
810              
811 1         3 $self->inject( @_ );
812 1 50       4 my $key = (@_==1) ? undef : shift( @_ );
813              
814             return Curio::Guard->new(sub{
815 1 50   1   5 $self->clear_injection( $key ? $key : () );
816 1         13 });
817             }
818              
819             =head2 clear_injection
820              
821             my $curio_object = $factory->clear_injection();
822             my $curio_object = $factory->clear_injection( $key );
823              
824             Removes the previously injected curio object, restoring the original
825             behavior of L.
826              
827             Returns the previously injected curio object, or C if there was
828             not one.
829              
830             =cut
831              
832             sub clear_injection {
833 3     3 1 6 my $self = shift;
834 3         7 my $key = $self->_process_key_arg( \@_ );
835              
836 3 50       16 $key = $undef_key if !defined $key;
837              
838 3         14 my $curio = $self->_remove_injection( $key );
839              
840 3         6 return $curio;
841             }
842              
843             =head2 injection
844              
845             my $curio_object = $factory->injection();
846             my $curio_object = $factory->injection( $key );
847              
848             Returns the injected curio object, or C if none has been
849             injected.
850              
851             =cut
852              
853             sub injection {
854 6     6 1 9 my $self = shift;
855 6         14 my $key = $self->_process_key_arg( \@_ );
856              
857 6 50       15 $key = $undef_key if !defined $key;
858              
859 6         15 return $self->_get_injection( $key );
860             }
861              
862             =head2 has_injection
863              
864             if ($factory->has_injection()) { ... }
865             if ($factory->has_injection( $key )) { ... }
866              
867             Returns true (C<1>) if an injection is in place.
868              
869             =cut
870              
871             sub has_injection {
872 0     0 1   my $self = shift;
873 0           my $key = $self->_process_key_arg( \@_ );
874              
875 0 0         $key = $undef_key if !defined $key;
876              
877 0 0         return $self->_get_injection( $key ) ? 1 : 0;
878             }
879              
880             1;
881             __END__