File Coverage

blib/lib/MooX/Failover.pm
Criterion Covered Total %
statement 59 63 93.6
branch 20 24 83.3
condition 10 13 76.9
subroutine 11 11 100.0
pod 1 1 100.0
total 101 112 90.1


line stmt bran cond sub pod time code
1             package MooX::Failover;
2             $MooX::Failover::VERSION = 'v0.3.3';
3 5     5   432279 use strict;
  5         13  
  5         218  
4 5     5   31 use warnings;
  5         6  
  5         232  
5              
6             require Moo;
7              
8 5     5   25 use Carp;
  5         12  
  5         402  
9 5     5   3052 use Class::Load qw/ try_load_class /;
  5         141022  
  5         371  
10 5     5   2910 use Sub::Defer qw/ undefer_sub /;
  5         13334  
  5         370  
11 5     5   3932 use Sub::Quote qw/ quote_sub /;
  5         10830  
  5         489  
12              
13             {
14 5     5   3239 use version 0.77;
  5         10628  
  5         46  
15             $MooX::Failover::VERSION = version->declare('v0.3.3');
16             }
17              
18             # RECOMMEND PREREQ: Class::Load::XS
19              
20             =head1 NAME
21              
22             MooX::Failover - Instantiate Moo classes with failover
23              
24             =for readme plugin version
25              
26             =head1 SYNOPSIS
27              
28             # In your class:
29              
30             package MyClass;
31              
32             use Moo;
33             use MooX::Failover;
34              
35             has 'attr' => ( ... );
36              
37             # after attributes are defined:
38              
39             failover_to 'OtherClass';
40              
41             ...
42              
43             # When using the class
44              
45             my $obj = MyClass->new( %args );
46              
47             # If %args contains missing or invalid values or new otherwise
48             # fails, then $obj will be of type "OtherClass".
49              
50             =begin :readme
51              
52             =head1 INSTALLATION
53              
54             See
55             L.
56              
57             =for readme plugin requires heading-level=2 title="Required Modules"
58              
59             =for readme plugin changes
60              
61             =end :readme
62              
63             =head1 DESCRIPTION
64              
65             This module provides constructor failover for L classes.
66              
67             For example, if a class cannot be instantiated because of invalid arguments
68             (perhaps from an untrusted source), then instead it returns the
69             failover class (passing the same arguments to that class).
70              
71             It is roughly equivalent to using
72              
73             my $obj = eval { MyClass->new(%args) //
74             OtherClass->new( %args, error => $@ );
75              
76             This allows for cleaner design, by not forcing you to duplicate type
77             checking for constructor parameters.
78              
79             =begin :readme
80              
81             See the module documentation for L for more information.
82              
83             =end :readme
84              
85             =for readme stop
86              
87             =head2 Use Cases
88              
89             A use case for this module is for instantiating
90             L objects, where a resource class's attributes
91             correspond to URL arguments. A type failure would normally cause an
92             internal serror error (HTTP 500). Using L, we can
93             return a different resource object that examines the error, and
94             returns a more appropriate error code, e.g. bad request (HTTP 400).
95              
96             Another use case for this module is for instantiating objects based on
97             their data sources. For example, to restrieve an object from a cache,
98             or to fail and retrieve it from the database instead.
99              
100             =head2 Design Considerations
101              
102             Your failover class should support the same methods as the original
103             class, so that it (roughly) satisfies the Liskov Substitution
104             Principle, where all provable properties of the original class are
105             also provable of the failover class. In practice, we only care about
106             the properties (methods and attributes) that are actually used in our
107             programs.
108              
109             =head1 EXPORTS
110              
111             The following function is always exported:
112              
113             =head2 C
114              
115             failover_to $class => %options;
116              
117             This specifies the class to instantiate if the constructor dies.
118              
119             It should be specified I all of the attributes have been
120             declared.
121              
122             Chained failovers are allowed:
123              
124             failover_to $first => %options1;
125             failover_to $second => %options2;
126             ...
127              
128             The following options are supported.
129              
130             =over
131              
132             =item C
133              
134             The name of the class to fail over to. It defaults to C<$class>.
135              
136             =item C
137              
138             The name of the constructor method in the failover class. It defaults
139             to "new".
140              
141             =item C
142              
143             The name of the constructor in the class that you are adding failover
144             to. It defaults to "new".
145              
146             Note that you can add failovers to multiple constructors. Suppose your
147             class has a "new" constructor, as well as a "new_from_file"
148             constructor that loads information from a file and then calls "new".
149             You can specify failovers for both of the constructors:
150              
151             failover_to 'OtherClass';
152              
153             failover_to 'OtherClass' => (
154             from_constructor => 'new_from_file',
155             );
156              
157             This option was added in v0.3.0.
158              
159             =item C
160              
161             The arguments to pass to the failover class. When omitted, it will
162             pass the same arguments as the original class.
163              
164             This can be a scalar (single argument), hash reference or array
165             reference.
166              
167             Note that the options are treated are treated as raw Perl code. To
168             use specify options, you need to explicitly add quotes to symbols, for
169             example:
170              
171             failover_to 'OtherClass' => (
172             args => [ map { "'$_'" } ( foo => 'bar' ) ],
173             );
174              
175             This option did not work properly until v0.3.0.
176              
177             =item C
178              
179             This is the name of the constructor argument to pass the error to (it
180             defaults to "error". This is useful if the failover class can inspect
181             the error and act appropriately.
182              
183             For example, if the original class is a handler for a website, where
184             the attributes correspond to URL parameters, then the failover class
185             can return HTTP 400 responses if the errors are for invalid
186             parameters.
187              
188             To disable it, set it to C.
189              
190             =item C
191              
192             This is the name of the constructor argument to pass the name of the
193             original class that failed. It defaults to "class".
194              
195             To disable it, set it to C.
196              
197             For chained failovers, it always contains the name of the original
198             class.
199              
200             =item C
201              
202             This is the name of the constructor to pass an array reference of the
203             original arguments passed to class. It is C by default.
204              
205             The original arguments are already passed to the failover class, but
206             this can be used to pass them all in a specific parameter.
207              
208             If you do not want the original arguments passed to the failover class
209             separately, set the C option to be empty:
210              
211             failover_to 'OtherClass' => (
212             args => [ ],
213             orig_args => 'failed_args',
214             );
215              
216             This option was added in v0.3.0.
217              
218             =back
219              
220             Note that unimporting L using
221              
222             no Moo;
223              
224             will also unimport L.
225              
226             =head1 ATTRIBUTES
227              
228             None. Since v0.2.0, there is no longer a C attribute.
229              
230             =cut
231              
232             sub import {
233 7     7   4368 my $caller = caller;
234 7         111 my $name = 'failover_to';
235 7         18 my $code = \&failover_to;
236 7         23 my $this = __PACKAGE__ . "::${name}";
237 7         15 my $that = "${caller}::${name}";
238 7         37 $Moo::MAKERS{$caller}{exports}{$name} = $code;
239 7         39 Moo::_install_coderef( $that, $this => $code );
240             }
241              
242             sub unimport {
243 1     1   532 my $caller = caller;
244 1         24 Moo::_unimport_coderefs( $caller,
245             { exports => { 'failover_to' => \&failover_to } } );
246             }
247              
248             sub _ref_to_list {
249 6     6   11 my ($next) = @_;
250              
251 6   100     50 my $args = $next->{args} // ['@_'];
252 6 50       23 if ( my $ref = ref $args ) {
253              
254 6 50       24 return ( @{$args} ) if $ref eq 'ARRAY';
  6         22  
255 0 0       0 return ( %{$args} ) if $ref eq 'HASH';
  0         0  
256              
257 0         0 croak "args must be an ArrayRef, HashRef or Str";
258              
259             }
260             else {
261              
262 0         0 return ($args);
263              
264             }
265              
266             }
267              
268             sub failover_to {
269 10     10 1 71544 my $class = shift;
270 10         34 my %next = @_;
271              
272 10   66     82 $next{class} //= $class;
273              
274 10 100       55 $next{class} or croak "no class defined";
275              
276 9 100       45 try_load_class( $next{class} )
277             or croak "unable to load " . $next{class};
278              
279 8         108451 my $caller = caller;
280 8 100       98 croak "cannot failover to self" if $next{class} eq $caller;
281              
282 7   100     48 $next{from_constructor} //= 'new';
283 7   100     30 $next{constructor} //= 'new';
284              
285 7 100       86 croak $next{class} . ' cannot ' . $next{constructor}
286             unless $next{class}->can( $next{constructor} );
287              
288 6 100 50     41 $next{err_arg} //= 'error' unless exists $next{err_arg};
289 6 100 50     31 $next{class_arg} //= 'class' unless exists $next{class_arg};
290              
291 6         18 my $orig_name = $caller . '::' . $next{from_constructor};
292 6         10 my $orig_code = undefer_sub \&{$orig_name};
  6         40  
293              
294 6         8400 my $next_name = $next{class} . '::' . $next{constructor};
295 6         12 my $next_code = undefer_sub \&{$next_name};
  6         30  
296              
297 6         4636 my @args = _ref_to_list(\%next);
298 6 100       33 push @args, $next{err_arg} . ' => $@' if defined $next{err_arg};
299 6 100       75 push @args, $next{class_arg} . " => '${caller}'"
300             if defined $next{class_arg};
301 6 100       24 push @args, $next{orig_arg} . ' => [@_]' if defined $next{orig_arg};
302              
303 6         33 my $code_str =
304             'eval { shift->$orig(@_); }' . ' // ' . $next{class} . '->$cont('
305             . join( ',', @args ) . ')';
306              
307 6         39 quote_sub $orig_name, $code_str, {
308             '$orig' => \$orig_code,
309             '$cont' => \$next_code,
310             };
311             }
312              
313             =for readme continue
314              
315             =head1 SEE ALSO
316              
317             This was originally a L port of L. The
318             interface was redesigned significantly, to be more efficient.
319              
320             =head1 AUTHOR
321              
322             Robert Rothenberg C<>
323              
324             =head2 Acknowledgements
325              
326             =over
327              
328             =item Thermeon.
329              
330             =item Piers Cawley.
331              
332             =item Gareth Kirwan.
333              
334             =back
335              
336             =head1 COPYRIGHT
337              
338             Copyright 2014 Thermeon Worldwide, PLC.
339              
340             This library is free software; you can redistribute it and/or modify
341             it under the same terms as Perl itself.
342              
343             This program is distributed in the hope that it will be useful, but
344             without any warranty; without even the implied warranty of
345             merchantability or fitness for a particular purpose.
346              
347             =cut
348              
349             1;