1 | # ------------------------------------------------------------------------------ |
---|
2 | # (C) British Crown Copyright 2006-17 Met Office. |
---|
3 | # |
---|
4 | # This file is part of FCM, tools for managing and building source code. |
---|
5 | # |
---|
6 | # FCM is free software: you can redistribute it and/or modify |
---|
7 | # it under the terms of the GNU General Public License as published by |
---|
8 | # the Free Software Foundation, either version 3 of the License, or |
---|
9 | # (at your option) any later version. |
---|
10 | # |
---|
11 | # FCM is distributed in the hope that it will be useful, |
---|
12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of |
---|
13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
---|
14 | # GNU General Public License for more details. |
---|
15 | # |
---|
16 | # You should have received a copy of the GNU General Public License |
---|
17 | # along with FCM. If not, see <http://www.gnu.org/licenses/>. |
---|
18 | # ------------------------------------------------------------------------------ |
---|
19 | use strict; |
---|
20 | use warnings; |
---|
21 | |
---|
22 | # ------------------------------------------------------------------------------ |
---|
23 | package FCM::System::Make::Share::Dest; |
---|
24 | use base qw{FCM::Class::CODE}; |
---|
25 | |
---|
26 | use Cwd qw{cwd}; |
---|
27 | use FCM::Context::Event; |
---|
28 | use FCM::System::Exception; |
---|
29 | use File::Basename qw{dirname}; |
---|
30 | use File::Path qw{mkpath rmtree}; |
---|
31 | use File::Spec::Functions qw{catfile rel2abs}; |
---|
32 | use File::Temp; |
---|
33 | use IO::Uncompress::Gunzip qw{gunzip}; |
---|
34 | use IO::Compress::Gzip qw{gzip}; |
---|
35 | use Scalar::Util qw{blessed reftype}; |
---|
36 | use Storable qw{fd_retrieve nstore_fd}; |
---|
37 | use Sys::Hostname qw{hostname}; |
---|
38 | |
---|
39 | # The relative paths for locating files in a destination |
---|
40 | our %PATH_OF = ( |
---|
41 | 'config' => 'fcm-make%s.cfg', |
---|
42 | 'config-orig' => 'fcm-make%s.cfg.orig', |
---|
43 | 'sys' => '.fcm-make%s', |
---|
44 | 'sys-cache' => '.fcm-make%s/cache', |
---|
45 | 'sys-config-as-parsed' => '.fcm-make%s/config-as-parsed.cfg', |
---|
46 | 'sys-config-as-parsed-symlink' => 'fcm-make%s-as-parsed.cfg', |
---|
47 | 'sys-config-on-success' => '.fcm-make%s/config-on-success.cfg', |
---|
48 | 'sys-config-on-success-symlink' => 'fcm-make%s-on-success.cfg', |
---|
49 | 'sys-ctx-uncompressed' => '.fcm-make%s/ctx', |
---|
50 | 'sys-ctx' => '.fcm-make%s/ctx.gz', |
---|
51 | 'sys-log' => '.fcm-make%s/log', |
---|
52 | 'sys-log-symlink' => 'fcm-make%s.log', |
---|
53 | 'sys-lock' => 'fcm-make%s.lock', |
---|
54 | 'sys-lock-info' => 'fcm-make%s.lock/info.txt', |
---|
55 | 'target' => '', |
---|
56 | ); |
---|
57 | |
---|
58 | # Aliases to exception classes |
---|
59 | my $E = 'FCM::System::Exception'; |
---|
60 | # List of actions |
---|
61 | my %ACTION_OF = ( |
---|
62 | ctx_load => \&_ctx_load, |
---|
63 | dest_done => \&_dest_done, |
---|
64 | dest_init => \&_dest_init, |
---|
65 | path => \&_path, |
---|
66 | paths => \&_paths, |
---|
67 | path_of => sub {$_[0]->{'path_of'}{$_[1]}}, |
---|
68 | save => \&_save, |
---|
69 | tidy => \&_tidy, |
---|
70 | ); |
---|
71 | |
---|
72 | # Creates the class. |
---|
73 | __PACKAGE__->class( |
---|
74 | { path_of => {isa => '%', default => {%PATH_OF}}, |
---|
75 | shared_util_of => '%', |
---|
76 | subsystem_of => '%', |
---|
77 | util => '&', |
---|
78 | }, |
---|
79 | {action_of => \%ACTION_OF}, |
---|
80 | ); |
---|
81 | |
---|
82 | # Loads a storable context from a path. |
---|
83 | sub _ctx_load { |
---|
84 | my ($attrib_ref, $m_ctx, $from) = @_; |
---|
85 | my $path; |
---|
86 | my $dest; |
---|
87 | if ($from) { |
---|
88 | NAME: |
---|
89 | for my $name ($m_ctx->get_name(), undef) { |
---|
90 | $path = _path( |
---|
91 | $attrib_ref, {'dest' => $from, 'name' => $name}, 'sys-ctx'); |
---|
92 | |
---|
93 | if (-f $path) { |
---|
94 | $dest = $from; |
---|
95 | last NAME; |
---|
96 | } |
---|
97 | } |
---|
98 | } |
---|
99 | else { |
---|
100 | $path = _path($attrib_ref, $m_ctx, 'sys-ctx'); |
---|
101 | $dest = $m_ctx->get_dest(); |
---|
102 | } |
---|
103 | my $old_m_ctx = eval { |
---|
104 | my $handle = File::Temp->new('TMPDIR' => 1); |
---|
105 | # Open the file here to work around permission problems with file ACLs |
---|
106 | open(my $path_handle, '<', $path) || die($!); |
---|
107 | gunzip($path_handle, $handle) || die($!); |
---|
108 | $handle->seek(0, 0); |
---|
109 | fd_retrieve($handle); |
---|
110 | }; |
---|
111 | if (my $e = $@) { |
---|
112 | return $E->throw($E->CACHE_LOAD, $path, $e); |
---|
113 | } |
---|
114 | if ( !$old_m_ctx |
---|
115 | || !$old_m_ctx->isa(blessed($m_ctx)) |
---|
116 | || ( defined($old_m_ctx->get_name()) |
---|
117 | && $old_m_ctx->get_name() ne $m_ctx->get_name() |
---|
118 | ) |
---|
119 | ) { |
---|
120 | return $E->throw($E->CACHE_TYPE, $path); |
---|
121 | } |
---|
122 | my $new_m_dest = rel2abs($dest); |
---|
123 | if ($new_m_dest ne $old_m_ctx->get_dest()) { |
---|
124 | my $old_m_dest = $old_m_ctx->get_dest(); |
---|
125 | $old_m_ctx->set_dest($new_m_dest); |
---|
126 | $old_m_ctx->set_dest_lock(undef); |
---|
127 | SUBSYSTEM: |
---|
128 | while (my ($id, $old_ctx) = each(%{$old_m_ctx->get_ctx_of()})) { |
---|
129 | my $id_of_class = $old_ctx->get_id_of_class(); |
---|
130 | if (exists($attrib_ref->{'subsystem_of'}{$id_of_class})) { |
---|
131 | my $subsystem = $attrib_ref->{'subsystem_of'}{$id_of_class}; |
---|
132 | if (!$old_ctx->can('set_dest')) { |
---|
133 | next SUBSYSTEM; |
---|
134 | } |
---|
135 | my $old_dest = $old_ctx->get_dest(); |
---|
136 | $old_ctx->set_dest(_path( |
---|
137 | $attrib_ref, |
---|
138 | {'dest' => $new_m_dest, 'name' => $m_ctx->get_name()}, |
---|
139 | 'target', |
---|
140 | $old_ctx->get_id(), |
---|
141 | )); |
---|
142 | if ($subsystem->can('ctx_load_hook')) { |
---|
143 | $subsystem->ctx_load_hook( |
---|
144 | $old_m_ctx, $old_ctx, $old_m_dest, $old_dest); |
---|
145 | } |
---|
146 | } |
---|
147 | } |
---|
148 | } |
---|
149 | return $old_m_ctx; |
---|
150 | } |
---|
151 | |
---|
152 | # Finalises the destination of a make context. |
---|
153 | sub _dest_done { |
---|
154 | my ($attrib_ref, $m_ctx) = @_; |
---|
155 | if (!$m_ctx->get_dest()) { |
---|
156 | return; |
---|
157 | } |
---|
158 | my $dest = _path($attrib_ref, $m_ctx, 'sys-ctx-uncompressed'); |
---|
159 | my $dest_parent = dirname($dest); |
---|
160 | my $dest_lock = $m_ctx->get_dest_lock(); |
---|
161 | $m_ctx->set_dest_lock(undef); |
---|
162 | if (-d $dest_parent) { |
---|
163 | eval { |
---|
164 | my $handle = File::Temp->new('TMPDIR' => 1); |
---|
165 | nstore_fd($m_ctx, $handle) || die($!); |
---|
166 | $handle->seek(0, 0) || die($!); |
---|
167 | gzip($handle, _path($attrib_ref, $m_ctx, 'sys-ctx')) || die($!); |
---|
168 | }; |
---|
169 | if (my $e = $@) { |
---|
170 | return $E->throw($E->DEST_CREATE, $dest, $e); |
---|
171 | } |
---|
172 | } |
---|
173 | my %ctx_of = %{$m_ctx->get_ctx_of()}; |
---|
174 | for my $path ( |
---|
175 | _path($attrib_ref, $m_ctx, 'sys'), |
---|
176 | (map {_path($attrib_ref, $m_ctx, 'target', $_)} keys(%ctx_of)), |
---|
177 | ) { |
---|
178 | _tidy($attrib_ref, $path); |
---|
179 | } |
---|
180 | if ($dest_lock) { |
---|
181 | rmtree($dest_lock); |
---|
182 | } |
---|
183 | } |
---|
184 | |
---|
185 | # Initialises the destination of a make context. |
---|
186 | sub _dest_init { |
---|
187 | my ($attrib_ref, $m_ctx) = @_; |
---|
188 | my %OPTION_OF = %{$m_ctx->get_option_of()}; |
---|
189 | # Select destination |
---|
190 | my $dest |
---|
191 | = $OPTION_OF{directory} ? $OPTION_OF{directory} |
---|
192 | : $m_ctx->get_dest() ? $m_ctx->get_dest() |
---|
193 | : cwd() |
---|
194 | ; |
---|
195 | $m_ctx->set_dest(rel2abs($dest)); |
---|
196 | # Check lock |
---|
197 | my $lock = _path($attrib_ref, $m_ctx, 'sys-lock'); |
---|
198 | if (!$OPTION_OF{'ignore-lock'} && -e $lock) { |
---|
199 | return $E->throw($E->DEST_LOCKED, $lock); |
---|
200 | } |
---|
201 | # Creates the lock (and the destination), if necessary |
---|
202 | if (!-e $lock) { |
---|
203 | eval {mkpath($lock)}; |
---|
204 | if (my $e = $@) { |
---|
205 | return $E->throw($E->DEST_CREATE, $lock, $e); |
---|
206 | } |
---|
207 | my $lock_info = scalar(getpwuid($<)) . '@' . hostname() . ':' . $$; |
---|
208 | _save($attrib_ref, $lock_info, $m_ctx, 'sys-lock-info'); |
---|
209 | } |
---|
210 | $m_ctx->set_dest_lock($lock); |
---|
211 | # Cleans items created by previous make, if necessary |
---|
212 | for my $path ( |
---|
213 | _path($attrib_ref, $m_ctx, 'sys-config-as-parsed-symlink'), |
---|
214 | _path($attrib_ref, $m_ctx, 'sys-config-on-success-symlink'), |
---|
215 | _path($attrib_ref, $m_ctx, 'sys-config-on-success'), |
---|
216 | _path($attrib_ref, $m_ctx, 'sys-log-symlink'), |
---|
217 | ) { |
---|
218 | eval {rmtree($path)}; |
---|
219 | if (my $e = $@) { |
---|
220 | return $E->throw($E->DEST_CLEAN, $path, $e); |
---|
221 | } |
---|
222 | } |
---|
223 | if ($OPTION_OF{new}) { |
---|
224 | my @steps = @{$m_ctx->get_steps()}; |
---|
225 | for my $path ( |
---|
226 | _path($attrib_ref, $m_ctx, 'sys'), |
---|
227 | (map {_path($attrib_ref, $m_ctx, 'target', $_)} @steps), |
---|
228 | ) { |
---|
229 | eval {rmtree($path)}; |
---|
230 | if (my $e = $@) { |
---|
231 | return $E->throw($E->DEST_CLEAN, $path, $e); |
---|
232 | } |
---|
233 | } |
---|
234 | } |
---|
235 | # Loads context of previous make, if possible |
---|
236 | my $prev_m_ctx = eval {_ctx_load($attrib_ref, $m_ctx)}; |
---|
237 | if (my $e = $@) { |
---|
238 | if ( !$E->caught($e) |
---|
239 | || !grep {$_ eq $e->get_code()} ($E->CACHE_LOAD, $E->CACHE_TYPE) |
---|
240 | ) { |
---|
241 | die($e); |
---|
242 | } |
---|
243 | $@ = undef; |
---|
244 | } |
---|
245 | if (defined($prev_m_ctx)) { |
---|
246 | $m_ctx->set_prev_ctx($prev_m_ctx); |
---|
247 | } |
---|
248 | else { |
---|
249 | # Creates the system directory |
---|
250 | my $sys_dir_path = _path($attrib_ref, $m_ctx, 'sys'); |
---|
251 | eval {mkpath($sys_dir_path)}; |
---|
252 | if (my $e = $@) { |
---|
253 | return $E->throw($E->DEST_CREATE, $sys_dir_path, $e); |
---|
254 | } |
---|
255 | } |
---|
256 | # Diagnostic |
---|
257 | $attrib_ref->{util}->event( |
---|
258 | FCM::Context::Event->MAKE_DEST, |
---|
259 | $m_ctx, join('@', scalar(getpwuid($<)), hostname()), |
---|
260 | ); |
---|
261 | 1; |
---|
262 | } |
---|
263 | |
---|
264 | # Returns the path of a named item relative to the context destination. |
---|
265 | sub _path { |
---|
266 | my ($attrib_ref, $m_ctx, $key, @paths) = @_; |
---|
267 | my %ctx = reftype($m_ctx) && reftype($m_ctx) eq 'HASH' |
---|
268 | ? %{$m_ctx} : ('dest' => $m_ctx, 'name' => q{}); |
---|
269 | $ctx{'dest'} ||= q{}; |
---|
270 | $ctx{'name'} ||= q{}; |
---|
271 | my $path_of_key = $attrib_ref->{path_of}{$key}; |
---|
272 | catfile( |
---|
273 | ($ctx{'dest'} ? $ctx{'dest'} : ()), |
---|
274 | split( |
---|
275 | q{/}, |
---|
276 | ($path_of_key ? sprintf($path_of_key, $ctx{'name'}) : $path_of_key), |
---|
277 | ), |
---|
278 | @paths, |
---|
279 | ); |
---|
280 | } |
---|
281 | |
---|
282 | # Returns an ARRAY reference containing the search paths of a named item |
---|
283 | # relative to the destinations of the context and its inherited contexts. |
---|
284 | sub _paths { |
---|
285 | my ($attrib_ref, $m_ctx, $key, @paths) = @_; |
---|
286 | my @dests; |
---|
287 | my @ctx_list = ($m_ctx); |
---|
288 | # Adds destinations from inherited contexts recursively |
---|
289 | # Note: if A inherits from B and C, B from B1 and B2, and C from C1 and C2, |
---|
290 | # the search path will be A, C, C2, C1, B, B2, B1. |
---|
291 | while (my $current_ctx = pop(@ctx_list)) { |
---|
292 | push(@ctx_list, @{$current_ctx->get_inherit_ctx_list()}); |
---|
293 | push(@dests, _path($attrib_ref, $current_ctx, $key, @paths)); |
---|
294 | } |
---|
295 | return \@dests; |
---|
296 | } |
---|
297 | |
---|
298 | # Saves $item in a path given by _path($attrib_ref, $m_ctx, $key, @paths). |
---|
299 | sub _save { |
---|
300 | my ($attrib_ref, $item, $m_ctx, $key, @paths) = @_; |
---|
301 | my $path = _path($attrib_ref, $m_ctx, $key, @paths); |
---|
302 | my @contents |
---|
303 | = (ref($item) && ref($item) eq 'ARRAY') ? (map {$_ . "\n"} @{$item}) |
---|
304 | : ($item . "\n") |
---|
305 | ; |
---|
306 | $attrib_ref->{util}->file_save($path, \@contents); |
---|
307 | } |
---|
308 | |
---|
309 | # Removes empty directories in a tree. |
---|
310 | sub _tidy { |
---|
311 | my ($attrib_ref, @paths) = @_; |
---|
312 | # Selects only directories which are not symbolic links |
---|
313 | my @items = map {[$_, undef, undef]} grep {-d && !-l} @paths; |
---|
314 | while (my $item = pop(@items)) { |
---|
315 | my ($path, $n_children_ref, $n_siblings_ref) = @{$item}; |
---|
316 | if (!defined($n_children_ref)) { |
---|
317 | opendir(my $handle, $path) |
---|
318 | || return $E->throw($E->DEST_CLEAN, $path, $!); |
---|
319 | my @children = grep {$_ ne q{.} && $_ ne q{..}} (readdir($handle)); |
---|
320 | closedir($handle); |
---|
321 | $n_children_ref = \scalar(@children); |
---|
322 | if (@children) { |
---|
323 | # Descends into directories |
---|
324 | my @sub_dirs |
---|
325 | = grep {-d && !-l} map {catfile($path, $_)} @children; |
---|
326 | if (@sub_dirs == @children) { |
---|
327 | # If all children are directories, it may be possible to |
---|
328 | # remove this directory later if all children are empty |
---|
329 | push(@items, [$path, $n_children_ref, $n_siblings_ref]); |
---|
330 | } |
---|
331 | push(@items, (map {[$_, undef, $n_children_ref]} @sub_dirs)); |
---|
332 | } |
---|
333 | } |
---|
334 | if (!${$n_children_ref}) { # i.e. directory is empty |
---|
335 | rmdir($path) || return $E->throw($E->DEST_CLEAN, $path, $!); |
---|
336 | if (defined($n_siblings_ref)) { |
---|
337 | --${$n_siblings_ref}; |
---|
338 | } |
---|
339 | } |
---|
340 | } |
---|
341 | } |
---|
342 | |
---|
343 | # ------------------------------------------------------------------------------ |
---|
344 | 1; |
---|
345 | __END__ |
---|
346 | |
---|
347 | =head1 NAME |
---|
348 | |
---|
349 | FCM::System::Make::Share::Dest |
---|
350 | |
---|
351 | =head1 SYNOPSIS |
---|
352 | |
---|
353 | use FCM::System::Make::Share::Dest; |
---|
354 | my $helper = FCM::System::Make::Share::Dest->new(\%attrib); |
---|
355 | my $ctx = $helper->ctx_load($path, $expected_class); |
---|
356 | my $path = $helper->path($m_ctx, $key); |
---|
357 | # ... |
---|
358 | |
---|
359 | =head1 DESCRIPTION |
---|
360 | |
---|
361 | A helper class for manipulating the destination of a context in a FCM make |
---|
362 | sub-system, e.g. extract. |
---|
363 | |
---|
364 | =head1 METHODS |
---|
365 | |
---|
366 | =over 4 |
---|
367 | |
---|
368 | =item $class->new(\%attrib) |
---|
369 | |
---|
370 | Returns a new instance. The %attrib should contain the following: |
---|
371 | |
---|
372 | =over 4 |
---|
373 | |
---|
374 | =item dest_items |
---|
375 | |
---|
376 | An ARRAY containing the names of the items that can be created at the context |
---|
377 | destination. |
---|
378 | |
---|
379 | =item path_of |
---|
380 | |
---|
381 | A HASH to map the (keys) names of the items and (values) their relative paths |
---|
382 | (as ARRAY) in a context destination. |
---|
383 | |
---|
384 | =back |
---|
385 | |
---|
386 | =item $instance->ctx_load($path,$expected_class) |
---|
387 | |
---|
388 | Loads a storable context from $path and returns the context. The $expected_class |
---|
389 | is the expected class of the loaded context. The method die() if it fails to |
---|
390 | load the context or if the loaded context does not belong to the expected class. |
---|
391 | |
---|
392 | =item $instance->dest_done($ctx) |
---|
393 | |
---|
394 | Finalises the destination of $ctx by freezing the $ctx in the system directory, |
---|
395 | removing the lock file, and tidying up any empty directories created by the |
---|
396 | system. |
---|
397 | |
---|
398 | =item $instance->dest_init($ctx) |
---|
399 | |
---|
400 | Initialises the destination of $ctx by checking for a lock directory in the |
---|
401 | destination, creating a lock if possible, cleaning up items created by the |
---|
402 | previous make of the system if necessary, and setting up the system directory. |
---|
403 | |
---|
404 | =item $instance->path($ctx,$key,@paths) |
---|
405 | |
---|
406 | Returns the path of a named item ($key) relative to $ctx, which can either be a |
---|
407 | HASH reference with {'dest' => $dest, 'name' => $name}, or a scalar path |
---|
408 | pointing to $dest, where $dest is the root of the path and $name is the name of |
---|
409 | the context. If @paths are specified, they are concatenated at the end |
---|
410 | of the path. |
---|
411 | |
---|
412 | =item $instance->paths($ctx,$key,@paths) |
---|
413 | |
---|
414 | Returns an ARRAY reference containing the search paths of a named item ($key) |
---|
415 | relative to the destinations of $ctx and its inherited contexts. If @paths are |
---|
416 | specified, they are concatenated at the end of each returned path. |
---|
417 | |
---|
418 | =item $instance->path_of($key) |
---|
419 | |
---|
420 | Returns the template value of the named item in a make destination. |
---|
421 | |
---|
422 | =item $instance->save($item,$ctx,$key,@paths) |
---|
423 | |
---|
424 | Saves $item in a path given by $instance->path($ctx,$key,@paths). $item can be a |
---|
425 | string or a reference to an ARRAY of strings. A "\n" is added to the end of each |
---|
426 | string. |
---|
427 | |
---|
428 | =item $instance->tidy(@paths) |
---|
429 | |
---|
430 | Recursively removes empty directories in @paths. |
---|
431 | |
---|
432 | =back |
---|
433 | |
---|
434 | =head1 CONSTANTS |
---|
435 | |
---|
436 | =over 4 |
---|
437 | |
---|
438 | =item %FCM::System::Make::PATH_OF |
---|
439 | |
---|
440 | A HASH containing the default values of named paths in a make destination. The |
---|
441 | following keys are used by the system: |
---|
442 | |
---|
443 | =over 4 |
---|
444 | |
---|
445 | =item config |
---|
446 | |
---|
447 | The standard path to the configuration file. |
---|
448 | |
---|
449 | =item sys |
---|
450 | |
---|
451 | The path to the system directory. |
---|
452 | |
---|
453 | =item sys-cache |
---|
454 | |
---|
455 | The path to the system cache directory. |
---|
456 | |
---|
457 | =item sys-config-as-parsed |
---|
458 | |
---|
459 | The path to the as-parsed configuration file. |
---|
460 | |
---|
461 | =item sys-config-on-success |
---|
462 | |
---|
463 | The path to the on-success configuration file. |
---|
464 | |
---|
465 | =item sys-ctx |
---|
466 | |
---|
467 | The path to the frozen make context (for retrieval by incremental makes). |
---|
468 | |
---|
469 | =item sys-ctx-uncompressed |
---|
470 | |
---|
471 | The path to the uncompressed form of sys-ctx. |
---|
472 | |
---|
473 | =item sys-lock |
---|
474 | |
---|
475 | The path to the lock directory. |
---|
476 | |
---|
477 | =item sys-lock-info |
---|
478 | |
---|
479 | The path to the lock info file. |
---|
480 | |
---|
481 | =item target |
---|
482 | |
---|
483 | The target destination of a make. |
---|
484 | |
---|
485 | =back |
---|
486 | |
---|
487 | =back |
---|
488 | |
---|
489 | =head1 DIAGNOSTICS |
---|
490 | |
---|
491 | =head2 FCM::System::Exception |
---|
492 | |
---|
493 | The methods of this class throws this exception on errors. |
---|
494 | |
---|
495 | =head1 TODO |
---|
496 | |
---|
497 | Time-stamp the as-parsed and the on-success configuration files. |
---|
498 | |
---|
499 | =head1 COPYRIGHT |
---|
500 | |
---|
501 | (C) Crown copyright Met Office. All rights reserved. |
---|
502 | |
---|
503 | =cut |
---|