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; |