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