File Coverage

blib/lib/Resource/Silo/Container.pm
Criterion Covered Total %
statement 143 143 100.0
branch 52 58 89.6
condition 28 33 84.8
subroutine 26 26 100.0
pod 2 2 100.0
total 251 262 95.8


line stmt bran cond sub pod time code
1             package Resource::Silo::Container;
2              
3 28     28   217 use strict;
  28         62  
  28         969  
4 28     28   153 use warnings;
  28         66  
  28         1252  
5             our $VERSION = '0.09';
6              
7             =head1 NAME
8              
9             Resource::Silo::Container - base resource container class for L.
10              
11             =head1 DESCRIPTION
12              
13             L isolates resources by storing them
14             inside a container object.
15              
16             The methods of such an object are generated on the fly and stored either
17             in a special virtual package, or the calling module.
18              
19             This class provides some common functionality that allows to access resources,
20             as well as a doorway into a fine-grained control interface.
21              
22             =head1 METHODS
23              
24             =cut
25              
26 28     28   169 use Carp;
  28         58  
  28         1639  
27 28     28   191 use Scalar::Util qw( blessed refaddr reftype weaken );
  28         52  
  28         1699  
28 28     28   174 use Module::Load qw( load );
  28         63  
  28         678  
29              
30             my $ID_REX = qr/^[a-z][a-z_0-9]*$/i;
31              
32             =head2 new( resource => $override, ... )
33              
34             Create a new container (also available as Cnew>).
35              
36             If arguments are given, they will be passed to the
37             L method (see below).
38              
39             =cut
40              
41             # NOTE to the editor. As we want to stay compatible with Moo/Moose,
42             # please make sure all internal fields start with a hyphen ("-").
43              
44             my %active_instances;
45             my $not_once = \%Resource::Silo::metadata; # avoid once warning
46              
47             sub new {
48 47     47 1 25320 my $class = shift;
49 47 100       245 $class = ref $class if blessed $class;
50              
51 47 50       208 my $spec = $Resource::Silo::metadata{$class}
52             or croak "Failed to locate \$Resource::Silo::metadata for class $class";
53              
54 47         332 my $self = bless {
55             -pid => $$,
56             -spec => $spec,
57             }, $class;
58 47 100       286 if (@_) {
59 4 100       50 croak "Odd number of additional arguments in new()"
60             if @_ % 2;
61 3         22 $self->_override_resources({ @_ });
62             };
63 46         354 $active_instances{ refaddr $self } = $self;
64 46         488 weaken $active_instances{ refaddr $self };
65 46         672 return $self;
66             };
67              
68             sub DESTROY {
69 28     28   500802 my $self = shift;
70 28         208 delete $active_instances{ refaddr $self };
71 28         201 $self->ctl->cleanup;
72             };
73              
74             # As container instances inside the silo() function will be available forever,
75             # we MUST enforce freeing the resources before program ends
76             END {
77 28     28   44244 foreach my $container (values %active_instances) {
78 19 50       85 next unless $container;
79 19         105 $container->ctl->cleanup;
80             };
81             };
82              
83             =head2 C
84              
85             As the container class may contain arbitrary resource names and
86             user-defined methods to boot, we intend to declare as few public methods
87             as possible.
88              
89             Instead, we create a facade object that has access to container's internals
90             and can perform fine-grained management operations.
91             See L below.
92              
93             Example:
94              
95             # Somewhere in a test file
96             use Test::More;
97             use My::App qw(silo);
98              
99             silo->ctl->override( dbh => $fake_database_connection );
100             silo->ctl->lock; # forbid instantiating new resources
101              
102             Returns a facade object.
103              
104             B Such object contains a weak reference to the parent object
105             and thus must not be saved anywhere, lest you be surprised.
106             Use it and discard immediately.
107              
108             =cut
109              
110             sub ctl {
111 74     74 1 3401 my $self = shift;
112 74         331 my $facade = bless \$self, 'Resource::Silo::Container::Dashboard';
113 74         455 weaken $$facade;
114 74 50       249 confess "Attempt to close over nonexistent value"
115             unless $$facade;
116 74         367 return $facade;
117             };
118              
119             # Instantiate resource $name with argument $argument.
120             # This is what a silo->resource_name calls after checking the cache.
121             sub _instantiate_resource {
122 101     101   304 my ($self, $name, $arg) = @_;
123              
124 101 100       825 croak "Illegal resource name '$name'"
125             unless $name =~ $ID_REX;
126              
127 99         277 my $spec = $self->{-spec}{resource}{$name};
128 99   100     475 $arg //= '';
129              
130 99 100       255 croak "Attempting to fetch nonexistent resource '$name'"
131             unless $spec;
132 98 100       244 croak "Argument for resource '$name' must be a scalar"
133             if ref $arg;
134             croak "Illegal argument for resource '$name': '$arg'"
135 97 100       421 unless $spec->{argument}->($arg);
136              
137             croak "Attempting to initialize resource '$name' during cleanup"
138 95 100       307 if $self->{-cleanup};
139             croak "Attempting to initialize resource '$name' in locked mode"
140             if $self->{-locked}
141             and !$spec->{derived}
142 94 100 100     350 and !$self->{-override}{$name};
      100        
143              
144             croak "Attempting to fetch unexpected dependency '$name'"
145 93 50 66     372 if ($self->{-allow} && !$self->{-allow}{$name});
146 93         239 local $self->{-allow} = $spec->{allowdeps};
147              
148             # Detect circular dependencies
149 93 100       331 my $key = $name . (length $arg ? "\@$arg" : '');
150 93 100       288 if ($self->{-pending}{$key}) {
151 1         6 my $loop = join ', ', sort keys %{ $self->{-pending} };
  1         8  
152 1         28 croak "Circular dependency detected for resource $key: {$loop}";
153             };
154 92         232 local $self->{-pending}{$key} = 1;
155              
156 92         161 foreach my $mod (@{ $spec->{require} }) {
  92         243  
157 6 100       20 eval { load $mod; 1 }
  6         27  
  5         8185  
158             or croak "resource '$name': failed to load '$mod': $@";
159             };
160 91   66     593 ($self->{-override}{$name} // $spec->{init})->($self, $name, $arg)
      66        
161             // croak "Fetching resource '$key' failed for no apparent reason";
162             };
163              
164             # use instead of delete $self->{-cache}{$name}
165             sub _cleanup_resource {
166 75     75   213 my ($self, $name, @list) = @_;
167              
168             # TODO Do we need to validate arguments here?
169 75         163 my $spec = $self->{-spec}{resource}{$name};
170              
171 75         122 my $action;
172 75 100       261 if (!$self->{-override}{$name}) {
173             # 1) skip resources that have overrides
174             # 2) if we're in "no pid" mode, use fork_cleanup if available
175             $action = $self->{-pid} != $$
176             && $spec->{fork_cleanup}
177 71   100     622 || $spec->{cleanup};
178             };
179 75         155 my $known = $self->{-cache}{$name};
180              
181 75 50       407 @list = keys %$known
182             unless @list;
183              
184 75         201 foreach my $arg (@list) {
185 85   50     253 $arg //= '';
186 85 100       855 next unless defined $known->{$arg};
187 73 100       285 $action->($known->{$arg}) if $action;
188 72         279 delete $known->{$arg};
189             };
190             };
191              
192             # We must create resource accessors in this package
193             # so that errors get attributed correctly
194             # (+ This way no other classes need to know our internal structure)
195             sub _make_resource_accessor {
196 60     60   199 my ($name, $spec) = @_;
197              
198 60 100       226 if ($spec->{ignore_cache}) {
199             return sub {
200 3     3   9 my ($self, $arg) = @_;
201 3         48 return $self->_instantiate_resource($name, $arg);
202 1         9 };
203             };
204              
205             return sub {
206 109     109   82089 my ($self, $arg) = @_;
207              
208             # If there was a fork, flush cache
209 109 100       449 if ($self->{-pid} != $$) {
210 1         71 $self->ctl->cleanup;
211 1         26 $self->{-pid} = $$;
212             };
213              
214             croak "Attempting to fetch unexpected dependency '$name'"
215 109 100 100     463 if ($self->{-allow} && !$self->{-allow}{$name});
216              
217             # Stringify $arg ASAP, we'll validate it inside _instantiate_resource().
218             # The cache entry for an invalid argument will never get populated.
219 106 100 100     448 my $key = defined $arg && !ref $arg ? $arg : '';
220 106   100     972 $self->{-cache}{$name}{$key} //= $self->_instantiate_resource($name, $arg);
221 59         524 };
222             };
223              
224             sub _check_overrides {
225 5     5   16 my ($self, $subst) = @_;
226              
227 5         11 my $known = $self->{-spec}{resource};
228 5         20 my @bad = grep { !$known->{$_} } keys %$subst;
  5         24  
229             croak "Attempt to override unknown resource(s): "
230 5 100       21 .join ", ", map { "'$_'" } @bad
  3         46  
231             if @bad;
232             };
233              
234             sub _override_resources {
235 5     5   21 my ($self, $subst) = @_;
236              
237 5         32 my $known = $self->{-spec}{resource};
238              
239 5         23 foreach my $name (keys %$subst) {
240             # Just skip over unknown resources if we're in constructor
241 6 100       22 next unless $known->{$name};
242 5         12 my $init = $subst->{$name};
243              
244             # Finalize existing values in cache, just in case
245             # BEFORE setting up override
246 5         37 $self->_cleanup_resource($name);
247              
248 5 100       24 if (defined $init) {
249             $self->{-override}{$name} = (reftype $init // '') eq 'CODE'
250             ? $init
251 4 50 50 4   106 : sub { $init };
  4         100  
252             } else {
253 1         2 delete $self->{-override}{$name};
254             };
255             };
256             }
257              
258             =head1 CONTROL INTERFACE
259              
260             The below methods are all accessible via
261             C<$container-Ectl-E$method_name>.
262              
263             =cut
264              
265             # We're declaring a different package in the same file because
266             # 1) it must have access to the internals anyway and
267             # 2) we want to keep the documentation close to the implementation.
268             package
269             Resource::Silo::Container::Dashboard;
270              
271 28     28   42167 use Carp;
  28         80  
  28         2027  
272 28     28   203 use Scalar::Util qw( reftype );
  28         58  
  28         15676  
273              
274             =head2 override( %substitutes )
275              
276             Provide a set of overrides for some of the resources.
277              
278             This can be used e.g. in tests to mock certain external facilities.
279              
280             %substitutes values are interpreted as follows:
281              
282             =over
283              
284             =item * C - use this code instead of the resource's C;
285              
286             =item * C - erase the override for given resource;
287              
288             =item * anything else is coerced into an initializer:
289             $value => sub { return $value }.
290              
291             =back
292              
293             Setting overrides has the side effect of clearing cache
294             for the affected resources.
295              
296             =cut
297              
298             sub override {
299 5     5   18 my ($self, %subst) = @_;
300              
301 5         28 $$self->_check_overrides(\%subst);
302 2         12 $$self->_override_resources(\%subst);
303              
304 2         8 return $self;
305             }
306              
307             =head2 lock
308              
309             Forbid initializing new resources.
310              
311             The cached ones instantiated so far, the ones that have been overridden,
312             and the ones with the C flag will still be returned.
313              
314             =cut
315              
316             sub lock {
317 2     2   6 my ($self) = @_;
318 2         6 $$self->{-locked} = 1;
319 2         7 return $self;
320             };
321              
322             =head2 unlock
323              
324             Remove the lock set by C.
325              
326             =cut
327              
328             sub unlock {
329 1     1   2 my $self = shift;
330 1         2 delete $$self->{-locked};
331 1         2 return $self;
332             };
333              
334             =head2 preload()
335              
336             Try loading all the resources that have C flag set.
337              
338             May be useful if e.g. a server-side application is starting and must
339             check its database connection(s) before it starts handling any clients.
340              
341             In addition, self-check will be called and all declared C'd
342             modules will be loaded, even if they are not required by preloaded resources.
343              
344             =cut
345              
346             sub preload {
347 2     2   5 my $self = shift;
348             # TODO allow specifying resources to load
349             # but first come up with a way to specify arguments, too.
350              
351 2         6 my $meta = $$self->{-spec};
352              
353 2         8 $meta->self_check;
354              
355 1         2 my $list = $meta->{preload};
356 1         2 for my $name (@$list) {
357 1         4 my $unused = $$self->$name;
358             };
359 1         10 return $self;
360             };
361              
362             =head2 cleanup
363              
364             Cleanup all resources.
365             Once the cleanup is started, no more resources can be created,
366             and trying to do so will result in exception.
367             Typically only useful for destruction.
368              
369             =cut
370              
371             sub cleanup {
372 50     50   94 my $self = ${ $_[0] };
  50         151  
373 50         147 local $self->{-cleanup} = 1; # This is stronger than lock.
374              
375             # NOTE Be careful! cleanup must never ever die!
376              
377 50         141 my $spec = $self->{-spec}{resource};
378             my @order = sort {
379 43         162 $spec->{$a}{cleanup_order} <=> $spec->{$b}{cleanup_order};
380 50         106 } keys %{ $self->{-cache} };
  50         334  
381              
382 50         180 foreach my $name (@order) {
383 70         135 local $@; # don't pollute $@ if we're in destructor after an exception
384             eval {
385             # We cannot afford to die here as if we do
386             # a resource that causes exceptions in cleanup
387             # would be stuck in cache forever
388 70         337 $self->_cleanup_resource($name);
389 69         304 1;
390 70 100       129 } or do {
391 1         256 my $err = $@;
392 1         13 Carp::cluck "Failed to cleanup resource '$name', but trying to continue: $err";
393             };
394             };
395              
396 50         827 delete $self->{-cache};
397 50         1159 return $_[0];
398             };
399              
400             =head2 fresh( $resource_name [, $argument ] )
401              
402             Instantiate resource and return it, ignoring cached value, if any.
403             This may be useful if the resource's state is going to be modified
404             in a manner incompatible with its other consumers within the same process.
405              
406             E.g. performing a Big Evil SQL Transaction while other parts of the application
407             are happily using L.
408              
409             B Use with caution.
410             Resorting to this method frequently may be a sign of a broader
411             architectural problem.
412              
413             =cut
414              
415             sub fresh {
416 8     8   15 return ${+shift}->_instantiate_resource(@_);
  8         28  
417             };
418              
419             =head2 meta
420              
421             Get resource metadata object (a L).
422              
423             =cut
424              
425             sub meta {
426 7     7   13 return ${+shift}->{-spec};
  7         45  
427             };
428              
429             =head1 COPYRIGHT AND LICENSE
430              
431             Copyright (c) 2023, Konstantin Uvarin, C<< >>
432              
433             This program is free software.
434             You can redistribute it and/or modify it under the terms of either:
435             the GNU General Public License as published by the Free Software Foundation,
436             or the Artistic License.
437              
438             See L for more information.
439              
440             =cut
441              
442             1;