1 | # ------------------------------------------------------------------------------ |
---|
2 | # Copyright (C) 2006-2021 British Crown (Met Office) & Contributors. |
---|
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::Extract; |
---|
24 | use base qw{FCM::Class::CODE}; |
---|
25 | |
---|
26 | use FCM::Context::ConfigEntry; |
---|
27 | use FCM::Context::Event; |
---|
28 | use FCM::Context::Make::Extract; |
---|
29 | use FCM::Context::Locator; |
---|
30 | use FCM::Context::Task; |
---|
31 | use FCM::System::Exception; |
---|
32 | use FCM::System::Make::Share::Subsystem; |
---|
33 | use File::Basename qw{dirname}; |
---|
34 | use File::Compare qw{compare}; |
---|
35 | use File::Copy qw{copy}; |
---|
36 | use File::Path qw{mkpath rmtree}; |
---|
37 | use File::Spec::Functions qw{abs2rel catfile tmpdir}; |
---|
38 | use File::Temp; |
---|
39 | use List::Util qw{first}; |
---|
40 | use Storable qw{dclone}; |
---|
41 | |
---|
42 | # Aliases |
---|
43 | our $UTIL; |
---|
44 | my $E = 'FCM::System::Exception'; |
---|
45 | |
---|
46 | # Configuration parser map: label to action |
---|
47 | our %CONFIG_PARSER_OF = ( |
---|
48 | 'location' => \&_config_parse_location, |
---|
49 | 'ns' => \&_config_parse_ns_list, |
---|
50 | 'path-excl' => _config_parse_path_func( |
---|
51 | sub {$_->get_path_excl()}, sub {$_->set_path_excl(@_)}, '@', |
---|
52 | ), |
---|
53 | 'path-incl' => _config_parse_path_func( |
---|
54 | sub {$_->get_path_incl()}, sub {$_->set_path_incl(@_)}, '@', |
---|
55 | ), |
---|
56 | 'path-root' => _config_parse_path_func( |
---|
57 | sub {$_->get_path_root()}, sub {$_->set_path_root(@_)}, |
---|
58 | ), |
---|
59 | ); |
---|
60 | |
---|
61 | # Properties from FCM::Util |
---|
62 | our @UTIL_PROP_KEYS = qw{diff3 diff3.flags}; |
---|
63 | |
---|
64 | # Creates the class. |
---|
65 | __PACKAGE__->class( |
---|
66 | { config_parser_of => {isa => '%', default => {%CONFIG_PARSER_OF}}, |
---|
67 | prop_of => '%', |
---|
68 | shared_util_of => '%', |
---|
69 | util => '&', |
---|
70 | }, |
---|
71 | { init => \&_init, |
---|
72 | action_of => { |
---|
73 | config_parse => \&_config_parse, |
---|
74 | config_parse_class_prop => \&_config_parse_class_prop, |
---|
75 | config_parse_inherit_hook => \&_config_parse_inherit_hook, |
---|
76 | config_unparse => \&_config_unparse, |
---|
77 | config_unparse_class_prop => \&_config_unparse_class_prop, |
---|
78 | ctx => \&_ctx, |
---|
79 | ctx_load_hook => \&_ctx_load_hook, |
---|
80 | main => \&_main, |
---|
81 | }, |
---|
82 | }, |
---|
83 | ); |
---|
84 | |
---|
85 | # Initialises the helpers of the class. |
---|
86 | sub _init { |
---|
87 | my ($attrib_ref) = @_; |
---|
88 | for my $util_prop_key (@UTIL_PROP_KEYS) { |
---|
89 | my $prop = $attrib_ref->{util}->external_cfg_get($util_prop_key); |
---|
90 | $attrib_ref->{prop_of}{$util_prop_key} = [$prop]; |
---|
91 | } |
---|
92 | } |
---|
93 | |
---|
94 | # Reads the extract.location declaration from a config entry. |
---|
95 | sub _config_parse_location { |
---|
96 | my ($attrib_ref, $ctx, $entry) = @_; |
---|
97 | if (!@{$entry->get_ns_list()}) { |
---|
98 | return $E->throw($E->CONFIG_NS, $entry); |
---|
99 | } |
---|
100 | my %PARSER_OF = ( |
---|
101 | 'base' => \&_config_parse_location_base, |
---|
102 | 'diff' => \&_config_parse_location_diff, |
---|
103 | 'primary' => \&_config_parse_location_primary, |
---|
104 | ); |
---|
105 | my %modifier_of = %{$entry->get_modifier_of()}; |
---|
106 | if (!grep {exists($modifier_of{$_})} keys(%PARSER_OF)) { |
---|
107 | $modifier_of{'base'} = 1; |
---|
108 | } |
---|
109 | for my $key (grep {exists($modifier_of{$_})} keys(%PARSER_OF)) { |
---|
110 | $PARSER_OF{$key}->($attrib_ref, $ctx, $entry); |
---|
111 | } |
---|
112 | } |
---|
113 | |
---|
114 | # Reads the extract.location{base} declaration from a config entry. |
---|
115 | sub _config_parse_location_base { |
---|
116 | my ($attrib_ref, $ctx, $entry) = @_; |
---|
117 | my %option; |
---|
118 | if (exists($entry->get_modifier_of()->{'type'})) { |
---|
119 | %option = ('type' => $entry->get_modifier_of()->{'type'}); |
---|
120 | } |
---|
121 | for my $ns (@{$entry->get_ns_list()}) { |
---|
122 | if (!exists($ctx->get_project_of()->{$ns})) { |
---|
123 | $ctx->get_project_of()->{$ns} = $ctx->CTX_PROJECT->new({ns => $ns}); |
---|
124 | } |
---|
125 | my $project = $ctx->get_project_of()->{$ns}; |
---|
126 | if ($project->get_inherited()) { |
---|
127 | if (!$entry->get_value()) { |
---|
128 | return $E->throw($E->CONFIG_VALUE, $entry); |
---|
129 | } |
---|
130 | my $locator = FCM::Context::Locator->new( |
---|
131 | $entry->get_value(), \%option, |
---|
132 | ); |
---|
133 | if ($project->get_locator()) { |
---|
134 | $attrib_ref->{util}->loc_rel2abs( |
---|
135 | $locator, |
---|
136 | $project->get_locator(), |
---|
137 | ); |
---|
138 | } |
---|
139 | $attrib_ref->{util}->loc_as_invariant($locator); |
---|
140 | my $i_locator = $project->get_trees()->[0]->get_locator(); |
---|
141 | if ($locator->get_value() ne $i_locator->get_value()) { |
---|
142 | return $E->throw($E->CONFIG_CONFLICT, $entry); |
---|
143 | } |
---|
144 | } |
---|
145 | else { |
---|
146 | if ( !exists($project->get_trees()->[0]) |
---|
147 | || !defined($project->get_trees()->[0]) |
---|
148 | ) { |
---|
149 | $project->get_trees()->[0] |
---|
150 | = $ctx->CTX_TREE->new({key => 0, ns => $ns}); |
---|
151 | } |
---|
152 | if ($entry->get_value()) { |
---|
153 | my $locator = FCM::Context::Locator->new( |
---|
154 | $entry->get_value(), \%option, |
---|
155 | ); |
---|
156 | $project->get_trees()->[0]->set_locator($locator); |
---|
157 | } |
---|
158 | else { |
---|
159 | $project->get_trees()->[0] = undef; |
---|
160 | } |
---|
161 | } |
---|
162 | } |
---|
163 | } |
---|
164 | |
---|
165 | # Reads the extract.location{diff} declaration from a config entry. |
---|
166 | sub _config_parse_location_diff { |
---|
167 | my ($attrib_ref, $ctx, $entry) = @_; |
---|
168 | my %option; |
---|
169 | if (exists($entry->get_modifier_of()->{'type'})) { |
---|
170 | %option = ('type' => $entry->get_modifier_of()->{'type'}); |
---|
171 | } |
---|
172 | for my $ns (@{$entry->get_ns_list()}) { |
---|
173 | if (!exists($ctx->get_project_of()->{$ns})) { |
---|
174 | $ctx->get_project_of()->{$ns} = $ctx->CTX_PROJECT->new({ns => $ns}); |
---|
175 | } |
---|
176 | my $project = $ctx->get_project_of()->{$ns}; |
---|
177 | my ($base, @diffs) = @{$project->get_trees()}; |
---|
178 | @diffs = grep { |
---|
179 | $_->get_inherited() |
---|
180 | || $option{type} |
---|
181 | && $_->get_locator()->get_type() |
---|
182 | && $option{type} ne $_->get_locator()->get_type() |
---|
183 | } @diffs; |
---|
184 | for my $value ($entry->get_values()) { |
---|
185 | if (!$value) { |
---|
186 | return $E->throw($E->CONFIG_VALUE, $entry); |
---|
187 | } |
---|
188 | push( |
---|
189 | @diffs, |
---|
190 | $ctx->CTX_TREE->new({ |
---|
191 | key => scalar(@diffs) + 1, |
---|
192 | locator => FCM::Context::Locator->new($value, \%option), |
---|
193 | ns => $ns, |
---|
194 | }), |
---|
195 | ); |
---|
196 | } |
---|
197 | @{$project->get_trees()} = ($base, @diffs); |
---|
198 | } |
---|
199 | } |
---|
200 | |
---|
201 | # Reads the extract.location{primary} declaration from a config entry. |
---|
202 | sub _config_parse_location_primary { |
---|
203 | my ($attrib_ref, $ctx, $entry) = @_; |
---|
204 | my %option; |
---|
205 | if (exists($entry->get_modifier_of()->{'type'})) { |
---|
206 | %option = ('type' => $entry->get_modifier_of()->{'type'}); |
---|
207 | } |
---|
208 | for my $ns (@{$entry->get_ns_list()}) { |
---|
209 | if (!exists($ctx->get_project_of()->{$ns})) { |
---|
210 | $ctx->get_project_of()->{$ns} = $ctx->CTX_PROJECT->new({ns => $ns}); |
---|
211 | } |
---|
212 | my $project = $ctx->get_project_of()->{$ns}; |
---|
213 | if ($entry->get_value()) { |
---|
214 | my $locator = FCM::Context::Locator->new( |
---|
215 | $entry->get_value(), \%option, |
---|
216 | ); |
---|
217 | $attrib_ref->{util}->loc_as_normalised($locator); |
---|
218 | if ($project->get_inherited()) { |
---|
219 | my $project_locator = $project->get_locator(); |
---|
220 | if ($project_locator->get_value() ne $locator->get_value()) { |
---|
221 | return $E->throw($E->CONFIG_CONFLICT, $entry); |
---|
222 | } |
---|
223 | } |
---|
224 | else { |
---|
225 | $project->set_locator($locator); |
---|
226 | } |
---|
227 | } |
---|
228 | else { |
---|
229 | $project->set_locator(undef); |
---|
230 | } |
---|
231 | } |
---|
232 | } |
---|
233 | |
---|
234 | # Reads the extract.ns declaration from a config entry. |
---|
235 | sub _config_parse_ns_list { |
---|
236 | my ($attrib_ref, $ctx, $entry) = @_; |
---|
237 | @{$ctx->get_ns_list()} = $entry->get_values(); |
---|
238 | } |
---|
239 | |
---|
240 | # Returns a function to parse extract.path-*. |
---|
241 | sub _config_parse_path_func { |
---|
242 | my ($getter, $setter, $isa) = @_; |
---|
243 | $isa ||= '$'; |
---|
244 | sub { |
---|
245 | my ($attrib_ref, $ctx, $entry) = @_; |
---|
246 | my @ns_list |
---|
247 | = @{$entry->get_ns_list()} ? @{$entry->get_ns_list()} |
---|
248 | : @{$ctx->get_ns_list()} |
---|
249 | ; |
---|
250 | for my $ns (@ns_list) { |
---|
251 | if (!exists($ctx->get_project_of()->{$ns})) { |
---|
252 | $ctx->get_project_of()->{$ns} |
---|
253 | = $ctx->CTX_PROJECT->new({ns => $ns}); |
---|
254 | } |
---|
255 | my $project = $ctx->get_project_of()->{$ns}; |
---|
256 | my $value = $entry->get_value(); |
---|
257 | if ($isa eq '@') { |
---|
258 | $value = [map {$_ eq q{/} ? q{} : $_} $entry->get_values()]; |
---|
259 | } |
---|
260 | local($_) = $project; |
---|
261 | if ($_->get_inherited()) { |
---|
262 | my $old = $getter->(); |
---|
263 | my $new = $value; |
---|
264 | if ($isa eq '@') { |
---|
265 | $old = _config_unparse_join(@{$old}); |
---|
266 | $new = _config_unparse_join(@{$new}); |
---|
267 | } |
---|
268 | if ($old ne $new) { |
---|
269 | return $E->throw($E->CONFIG_CONFLICT, $entry); |
---|
270 | } |
---|
271 | } |
---|
272 | else { |
---|
273 | $setter->($value); |
---|
274 | } |
---|
275 | } |
---|
276 | }; |
---|
277 | } |
---|
278 | |
---|
279 | # A hook command for the "inherit/use" declaration. |
---|
280 | sub _config_parse_inherit_hook { |
---|
281 | my ($attrib_ref, $ctx, $i_ctx) = @_; |
---|
282 | @{$ctx->get_ns_list()} = @{$i_ctx->get_ns_list()}; |
---|
283 | while (my ($ns, $i_project) = each(%{$i_ctx->get_project_of()})) { |
---|
284 | my $project = dclone($i_project); |
---|
285 | $project->set_inherited(1); |
---|
286 | for my $tree (@{$project->get_trees()}) { |
---|
287 | $tree->set_inherited(1); |
---|
288 | } |
---|
289 | $ctx->get_project_of()->{$ns} = $project; |
---|
290 | } |
---|
291 | _config_parse_inherit_hook_prop($attrib_ref, $ctx, $i_ctx); |
---|
292 | } |
---|
293 | |
---|
294 | # Turns a context into a list of configuration entries. |
---|
295 | sub _config_unparse { |
---|
296 | my ($attrib_ref, $ctx) = @_; |
---|
297 | my %LABEL_OF |
---|
298 | = map {($_ => $ctx->get_id() . q{.} . $_)} keys(%CONFIG_PARSER_OF); |
---|
299 | my @entries = ( |
---|
300 | FCM::Context::ConfigEntry->new({ |
---|
301 | label => $LABEL_OF{ns}, |
---|
302 | value => _config_unparse_join(@{$ctx->get_ns_list()}), |
---|
303 | }), |
---|
304 | ); |
---|
305 | for my $p_ns (sort keys(%{$ctx->get_project_of()})) { |
---|
306 | my $project = $ctx->get_project_of($p_ns); |
---|
307 | my ($base, @diffs) = @{$project->get_trees()}; |
---|
308 | if (!$project->get_inherited()) { |
---|
309 | if (defined($project->get_locator())) { |
---|
310 | my $locator = $project->get_locator(); |
---|
311 | my %modifier_of = (primary => 1, type => $locator->get_type()); |
---|
312 | push( |
---|
313 | @entries, |
---|
314 | FCM::Context::ConfigEntry->new({ |
---|
315 | label => $LABEL_OF{location}, |
---|
316 | modifier_of => \%modifier_of, |
---|
317 | ns_list => [$p_ns], |
---|
318 | value => $locator->get_value(), |
---|
319 | }), |
---|
320 | ); |
---|
321 | } |
---|
322 | if (@{$project->get_path_excl()}) { |
---|
323 | my @values = map {$_ ? $_ : q{/}} @{$project->get_path_excl()}; |
---|
324 | push( |
---|
325 | @entries, |
---|
326 | FCM::Context::ConfigEntry->new({ |
---|
327 | label => $LABEL_OF{'path-excl'}, |
---|
328 | ns_list => [$p_ns], |
---|
329 | value => _config_unparse_join(@values), |
---|
330 | }), |
---|
331 | ); |
---|
332 | } |
---|
333 | if (@{$project->get_path_incl()}) { |
---|
334 | my @values = map {$_ ? $_ : q{/}} @{$project->get_path_incl()}; |
---|
335 | push( |
---|
336 | @entries, |
---|
337 | FCM::Context::ConfigEntry->new({ |
---|
338 | label => $LABEL_OF{'path-incl'}, |
---|
339 | ns_list => [$p_ns], |
---|
340 | value => _config_unparse_join(@values), |
---|
341 | }), |
---|
342 | ); |
---|
343 | } |
---|
344 | if ($project->get_path_root()) { |
---|
345 | push( |
---|
346 | @entries, |
---|
347 | FCM::Context::ConfigEntry->new({ |
---|
348 | label => $LABEL_OF{'path-root'}, |
---|
349 | ns_list => [$p_ns], |
---|
350 | value => $project->get_path_root(), |
---|
351 | }), |
---|
352 | ); |
---|
353 | } |
---|
354 | my $value = $base->get_locator()->get_value(); |
---|
355 | push( |
---|
356 | @entries, |
---|
357 | FCM::Context::ConfigEntry->new({ |
---|
358 | label => $LABEL_OF{'location'}, |
---|
359 | modifier_of => {type => $base->get_locator()->get_type()}, |
---|
360 | ns_list => [$p_ns], |
---|
361 | value => $value, |
---|
362 | }), |
---|
363 | ); |
---|
364 | } |
---|
365 | @diffs = grep {!$_->get_inherited()} @diffs; |
---|
366 | if (@diffs) { |
---|
367 | my %type_set = map {($_->get_locator()->get_type() => 1)} @diffs; |
---|
368 | for my $type (sort(keys(%type_set))) { |
---|
369 | my $value = _config_unparse_join( |
---|
370 | map {$_->get_locator()->get_value()} |
---|
371 | grep {$_->get_locator()->get_type() eq $type} |
---|
372 | @diffs |
---|
373 | ); |
---|
374 | push( |
---|
375 | @entries, |
---|
376 | FCM::Context::ConfigEntry->new({ |
---|
377 | label => $LABEL_OF{'location'}, |
---|
378 | modifier_of => {diff => 1, type => $type}, |
---|
379 | ns_list => [$p_ns], |
---|
380 | value => $value, |
---|
381 | }), |
---|
382 | ); |
---|
383 | } |
---|
384 | } |
---|
385 | } |
---|
386 | push(@entries, _config_unparse_prop($attrib_ref, $ctx)); |
---|
387 | return @entries; |
---|
388 | } |
---|
389 | |
---|
390 | # Returns a new context. |
---|
391 | sub _ctx { |
---|
392 | my ($attrib_ref, $id_of_class, $id) = @_; |
---|
393 | FCM::Context::Make::Extract->new({id => $id, id_of_class => $id_of_class}); |
---|
394 | } |
---|
395 | |
---|
396 | # Hook when loading a previous ctx. |
---|
397 | sub _ctx_load_hook { |
---|
398 | my ($attrib_ref, $old_m_ctx, $old_ctx, $old_m_dest, $old_dest) = @_; |
---|
399 | my $path_mod_func = sub { |
---|
400 | my ($get_func, $set_func) = @_; |
---|
401 | my $path = $get_func->(); |
---|
402 | if (!defined($path)) { |
---|
403 | return; |
---|
404 | } |
---|
405 | my $rel_path = abs2rel($path, $old_m_dest); |
---|
406 | if (index($rel_path, '..') != 0) { |
---|
407 | $set_func->(catfile($old_m_ctx->get_dest(), $rel_path)); |
---|
408 | } |
---|
409 | }; |
---|
410 | while (my ($ns, $project) = each(%{$old_ctx->get_project_of()})) { |
---|
411 | $path_mod_func->( |
---|
412 | sub {$project->get_cache()}, |
---|
413 | sub {$project->set_cache(@_)}, |
---|
414 | ); |
---|
415 | for my $tree (@{$project->get_trees()}) { |
---|
416 | $path_mod_func->( |
---|
417 | sub {$tree->get_cache()}, |
---|
418 | sub {$tree->set_cache(@_)}, |
---|
419 | ); |
---|
420 | for my $source (@{$tree->get_sources()}) { |
---|
421 | $path_mod_func->( |
---|
422 | sub {$source->get_cache()}, |
---|
423 | sub {$source->set_cache(@_)}, |
---|
424 | ); |
---|
425 | } |
---|
426 | } |
---|
427 | } |
---|
428 | while (my ($key, $target) = each(%{$old_ctx->get_target_of()})) { |
---|
429 | $path_mod_func->( |
---|
430 | sub {$target->get_path()}, |
---|
431 | sub {$target->set_path(@_)}, |
---|
432 | ); |
---|
433 | $path_mod_func->( |
---|
434 | sub {$target->get_dests()->[0]}, |
---|
435 | sub {$target->get_dests()->[0] = $_[0]}, |
---|
436 | ); |
---|
437 | while (my ($ns, $source) = each(%{$target->get_source_of()})) { |
---|
438 | $path_mod_func->( |
---|
439 | sub {$source->get_cache()}, |
---|
440 | sub {$source->set_cache(@_)}, |
---|
441 | ); |
---|
442 | } |
---|
443 | } |
---|
444 | } |
---|
445 | |
---|
446 | # The main function of this class. |
---|
447 | sub _main { |
---|
448 | my ($attrib_ref, $m_ctx, $ctx) = @_; |
---|
449 | local($UTIL) = $attrib_ref->{util}; |
---|
450 | for my $function ( |
---|
451 | \&_elaborate_ctx_of_project, |
---|
452 | \&_elaborate_ctx_of_target, |
---|
453 | \&_extract_incremental, |
---|
454 | \&_project_tree_caches_update, |
---|
455 | \&_symlink_handle, |
---|
456 | \&_targets_update, |
---|
457 | ) { |
---|
458 | $function->($attrib_ref, $m_ctx, $ctx); |
---|
459 | } |
---|
460 | } |
---|
461 | |
---|
462 | # Elaborates the context: project and tree. |
---|
463 | sub _elaborate_ctx_of_project { |
---|
464 | my ($attrib_ref, $m_ctx, $ctx) = @_; |
---|
465 | |
---|
466 | # Reports projects that are not used |
---|
467 | my @bad_ns_list; |
---|
468 | while (my ($p_ns, $project) = each(%{$ctx->get_project_of()})) { |
---|
469 | if ( !$project->get_inherited() |
---|
470 | && !grep {$_ eq $p_ns} @{$ctx->get_ns_list()} |
---|
471 | ) { |
---|
472 | push(@bad_ns_list, $p_ns); |
---|
473 | } |
---|
474 | } |
---|
475 | if (@bad_ns_list) { |
---|
476 | return $E->throw($E->EXTRACT_NS, \@bad_ns_list); |
---|
477 | } |
---|
478 | |
---|
479 | # Determines a list of new trees |
---|
480 | my $prev_m_ctx = $m_ctx->get_prev_ctx(); |
---|
481 | my $prev_ctx |
---|
482 | = defined($prev_m_ctx) ? $prev_m_ctx->get_ctx_of($ctx->get_id()) |
---|
483 | : undef |
---|
484 | ; |
---|
485 | my @trees; # list of new trees |
---|
486 | for my $p_ns (@{$ctx->get_ns_list()}) { |
---|
487 | # Ensures the project settings are defined |
---|
488 | if (!exists($ctx->get_project_of()->{$p_ns})) { |
---|
489 | $ctx->get_project_of()->{$p_ns} |
---|
490 | = $ctx->CTX_PROJECT->new({ns => $p_ns}); |
---|
491 | } |
---|
492 | my $project = $ctx->get_project_of()->{$p_ns}; |
---|
493 | |
---|
494 | # Determine the root location of the project, if possible |
---|
495 | if (defined($project->get_locator())) { |
---|
496 | $UTIL->loc_as_normalised($project->get_locator()); |
---|
497 | } |
---|
498 | else { |
---|
499 | my $uri = $UTIL->loc_kw_prefix() . ':' . $p_ns; |
---|
500 | my $locator = FCM::Context::Locator->new($uri); |
---|
501 | local($@); |
---|
502 | eval {$UTIL->loc_as_normalised($locator)}; |
---|
503 | if (!$@) { |
---|
504 | $project->set_locator($locator); |
---|
505 | } |
---|
506 | } |
---|
507 | # Ensures base tree is defined |
---|
508 | if (!@{$project->get_trees()} || !defined($project->get_trees()->[0])) { |
---|
509 | if (!defined($project->get_locator())) { |
---|
510 | return $E->throw($E->EXTRACT_LOC_BASE, $p_ns); |
---|
511 | } |
---|
512 | my $head_locator = $UTIL->loc_trunk_at_head($project->get_locator()); |
---|
513 | my $locator |
---|
514 | = $head_locator ? $head_locator |
---|
515 | : dclone($project->get_locator()) |
---|
516 | ; |
---|
517 | $project->get_trees()->[0] = $ctx->CTX_TREE->new( |
---|
518 | {key => 0, locator => $locator, ns => $p_ns}, |
---|
519 | ); |
---|
520 | } |
---|
521 | # Determine whether there is a usable previous extract |
---|
522 | my %path_excl = map {($_, 1)} @{$project->get_path_excl()}; |
---|
523 | my %path_incl = map {($_, 1)} @{$project->get_path_incl()}; |
---|
524 | my $path_root = $project->get_path_root(); |
---|
525 | my ($can_use_prev, $prev_project); |
---|
526 | if (defined($prev_ctx) && defined($prev_ctx->get_project_of($p_ns))) { |
---|
527 | $prev_project = $prev_ctx->get_project_of($p_ns); |
---|
528 | my %prev_path_excl = map {($_, 1)} @{$prev_project->get_path_excl()}; |
---|
529 | my %prev_path_incl = map {($_, 1)} @{$prev_project->get_path_incl()}; |
---|
530 | my $prev_path_root = $prev_project->get_path_root(); |
---|
531 | $can_use_prev |
---|
532 | = $prev_ctx->get_status() eq $m_ctx->ST_OK |
---|
533 | && !$UTIL->hash_cmp(\%path_excl, \%prev_path_excl, 1) |
---|
534 | && !$UTIL->hash_cmp(\%path_incl, \%prev_path_incl, 1) |
---|
535 | && $path_root eq $prev_path_root |
---|
536 | ; |
---|
537 | } |
---|
538 | # Tree locators as invariant |
---|
539 | TREE: |
---|
540 | for my $tree (grep {!$_->get_inherited()} @{$project->get_trees()}) { |
---|
541 | my $tree_locator = $tree->get_locator(); |
---|
542 | # Ensures that the tree locator is an absolute path |
---|
543 | if (defined($project->get_locator())) { |
---|
544 | $UTIL->loc_rel2abs($tree_locator, $project->get_locator()); |
---|
545 | } |
---|
546 | # Determines invariant form of the locator of the project tree. |
---|
547 | $UTIL->loc_as_invariant($tree_locator); |
---|
548 | } |
---|
549 | # Remove diff trees that are the same as the base tree |
---|
550 | my ($base_tree, @old_diff_trees) = @{$project->get_trees()}; |
---|
551 | my $base_value = $base_tree->get_locator()->get_value(); |
---|
552 | my @new_diff_trees; |
---|
553 | TREE: |
---|
554 | for my $tree (@old_diff_trees) { |
---|
555 | if ($base_value ne $tree->get_locator()->get_value()) { |
---|
556 | push(@new_diff_trees, $tree); |
---|
557 | $tree->set_key(scalar(@new_diff_trees)); # reset key (index) |
---|
558 | } |
---|
559 | } |
---|
560 | $project->set_trees([$base_tree, @new_diff_trees]); |
---|
561 | # Determine the new trees |
---|
562 | TREE: |
---|
563 | for my $tree (grep {!$_->get_inherited()} @{$project->get_trees()}) { |
---|
564 | my $tree_locator = $tree->get_locator(); |
---|
565 | if ( $can_use_prev |
---|
566 | && $tree_locator->get_value_level() >= $tree_locator->L_INVARIANT |
---|
567 | ) { |
---|
568 | my $prev_tree = first { |
---|
569 | $tree_locator->get_value() eq $_->get_locator()->get_value() |
---|
570 | } @{$prev_project->get_trees()}; |
---|
571 | if ($prev_tree) { |
---|
572 | my $prev_tree_locator = $prev_tree->get_locator(); |
---|
573 | $tree->set_sources($prev_tree->get_sources()); |
---|
574 | if ($tree->get_key() || !$prev_tree->get_key()) { |
---|
575 | # Only safe to re-use cache if both are base trees |
---|
576 | # or for diff tree with an unchanged base tree |
---|
577 | $tree->set_cache($prev_tree->get_cache()); |
---|
578 | } |
---|
579 | next TREE; |
---|
580 | } |
---|
581 | if (!$tree->get_key()) { # base tree changed |
---|
582 | $can_use_prev = 0; |
---|
583 | } |
---|
584 | } |
---|
585 | push(@trees, $tree); # new tree |
---|
586 | } |
---|
587 | } |
---|
588 | |
---|
589 | # Obtain source info for each new tree, using the task runner |
---|
590 | if (@trees) { |
---|
591 | my $timer = $UTIL->timer(); |
---|
592 | my $n_jobs = $m_ctx->get_option_of('jobs'); |
---|
593 | if ($n_jobs && $n_jobs > scalar(@trees)) { |
---|
594 | $n_jobs = scalar(@trees); |
---|
595 | } |
---|
596 | my $elapse_tasks = 0; |
---|
597 | my $runner = $UTIL->task_runner( |
---|
598 | sub {_elaborate_ctx_of_project_tree($attrib_ref, $m_ctx, $ctx, @_)}, |
---|
599 | $n_jobs, |
---|
600 | ); |
---|
601 | my $n = eval { |
---|
602 | $runner->main( |
---|
603 | # get |
---|
604 | sub { |
---|
605 | if (!@trees) { |
---|
606 | return; |
---|
607 | } |
---|
608 | my $tree = shift(@trees); |
---|
609 | my $id = join(':', $tree->get_ns(), $tree->get_key()); |
---|
610 | FCM::Context::Task->new({ctx => $tree, id => $id}); |
---|
611 | }, |
---|
612 | # put |
---|
613 | sub { |
---|
614 | my ($task) = @_; |
---|
615 | if ($task->get_state() eq $task->ST_FAILED) { |
---|
616 | die($task->get_error()); |
---|
617 | } |
---|
618 | my $ns = $task->get_ctx()->get_ns(); |
---|
619 | my $key = $task->get_ctx()->get_key(); |
---|
620 | my $project = $ctx->get_project_of()->{$ns}; |
---|
621 | my $tree = $project->get_trees()->[$key]; |
---|
622 | $tree->set_locator($task->get_ctx()->get_locator()); |
---|
623 | $tree->set_sources($task->get_ctx()->get_sources()); |
---|
624 | $elapse_tasks += $task->get_elapse(); |
---|
625 | }, |
---|
626 | ); |
---|
627 | }; |
---|
628 | my $e = $@; |
---|
629 | $runner->destroy(); |
---|
630 | if ($e) { |
---|
631 | die($e); |
---|
632 | } |
---|
633 | $UTIL->event( |
---|
634 | FCM::Context::Event->MAKE_EXTRACT_RUNNER_SUMMARY, |
---|
635 | 'tree-sources-info-get', $n, $timer->(), $elapse_tasks, |
---|
636 | ); |
---|
637 | } |
---|
638 | $UTIL->event( |
---|
639 | FCM::Context::Event->MAKE_EXTRACT_PROJECT_TREE, |
---|
640 | { map {($_ => [ |
---|
641 | map {$_->get_locator()} |
---|
642 | @{$ctx->get_project_of()->{$_}->get_trees()} |
---|
643 | ])} |
---|
644 | sort keys(%{$ctx->get_project_of()}) |
---|
645 | }, |
---|
646 | ); |
---|
647 | } |
---|
648 | |
---|
649 | # Elaborates the context: new tree in a project. |
---|
650 | sub _elaborate_ctx_of_project_tree { |
---|
651 | my ($attrib_ref, $m_ctx, $ctx, $tree) = @_; |
---|
652 | my $project = $ctx->get_project_of()->{$tree->get_ns()}; |
---|
653 | my $path_root = $project->get_path_root(); |
---|
654 | # TODO: support regular expression or wildcards? |
---|
655 | my %path_incl = map {($_ => 1)} @{$project->get_path_incl()}; |
---|
656 | my %path_excl = map {($_ => 1)} @{$project->get_path_excl()}; |
---|
657 | $UTIL->loc_find( |
---|
658 | $tree->get_locator(), |
---|
659 | sub { |
---|
660 | my ($locator, $locator_attrib_ref) = @_; |
---|
661 | if ($locator_attrib_ref->{is_dir}) { |
---|
662 | return; |
---|
663 | } |
---|
664 | my $ns_in_tree = $locator_attrib_ref->{ns}; |
---|
665 | my $ns = $ns_in_tree; |
---|
666 | if ($path_root) { |
---|
667 | if ($path_root ne $UTIL->ns_common($path_root, $ns)) { |
---|
668 | return; |
---|
669 | } |
---|
670 | $ns = $ns eq $path_root ? q{} |
---|
671 | : substr($ns, length($path_root) + 1) |
---|
672 | ; |
---|
673 | } |
---|
674 | my $ns_iter_ref = $UTIL->ns_iter($ns, $UTIL->NS_ITER_UP); |
---|
675 | NS: |
---|
676 | while (defined(my $head = $ns_iter_ref->())) { |
---|
677 | if (exists($path_incl{$head})) { |
---|
678 | last NS; |
---|
679 | } |
---|
680 | if (exists($path_excl{$head})) { |
---|
681 | return; |
---|
682 | } |
---|
683 | } |
---|
684 | push( |
---|
685 | @{$tree->get_sources()}, |
---|
686 | $ctx->CTX_SOURCE->new({ |
---|
687 | key_of_tree => $tree->get_key(), |
---|
688 | locator => $locator, |
---|
689 | ns => $UTIL->ns_cat($tree->get_ns(), $ns), |
---|
690 | ns_in_tree => $ns_in_tree, |
---|
691 | }), |
---|
692 | ); |
---|
693 | }, |
---|
694 | ); |
---|
695 | $tree; |
---|
696 | } |
---|
697 | |
---|
698 | # Elaborates the context: target. |
---|
699 | sub _elaborate_ctx_of_target { |
---|
700 | my ($attrib_ref, $m_ctx, $ctx) = @_; |
---|
701 | # Works out the extract sources and targets |
---|
702 | my $DEST = $attrib_ref->{shared_util_of}{dest}; |
---|
703 | my $ns_sep = $UTIL->ns_sep(); |
---|
704 | while (my ($p_ns, $project) = each(%{$ctx->get_project_of()})) { |
---|
705 | my ($tree_base, @trees) = @{$project->get_trees()}; |
---|
706 | # Sources from the base tree |
---|
707 | for my $source (@{$tree_base->get_sources()}) { |
---|
708 | my $ns = $source->get_ns(); |
---|
709 | my @paths = split($ns_sep, $ns); |
---|
710 | my $dest_list_ref = $DEST->paths( |
---|
711 | $m_ctx, 'target', $ctx->get_id(), @paths |
---|
712 | ); |
---|
713 | $ctx->get_target_of()->{$ns} = $ctx->CTX_TARGET->new({ |
---|
714 | dests => $dest_list_ref, |
---|
715 | ns => $ns, |
---|
716 | source_of => {$tree_base->get_key() => $source}, |
---|
717 | }); |
---|
718 | } |
---|
719 | my %sources_in_base |
---|
720 | = map {($_->get_ns() => $_)} @{$tree_base->get_sources()}; |
---|
721 | # Sources from the diff trees |
---|
722 | for my $tree (@trees) { |
---|
723 | my $key = $tree->get_key(); |
---|
724 | my %sources_deleted = %sources_in_base; |
---|
725 | # Handles new/modified sources |
---|
726 | for my $source (@{$tree->get_sources()}) { |
---|
727 | my $ns = $source->get_ns(); |
---|
728 | delete($sources_deleted{$ns}); |
---|
729 | if (exists($ctx->get_target_of()->{$ns})) { |
---|
730 | my $target = $ctx->get_target_of()->{$ns}; |
---|
731 | my $base_source = $target->get_source_of()->{0}; |
---|
732 | if ( $base_source->get_locator() |
---|
733 | && _source_eq($base_source, $source) |
---|
734 | ) { |
---|
735 | $source->set_status($source->ST_UNCHANGED); |
---|
736 | } |
---|
737 | else { |
---|
738 | # Source modified by diff tree |
---|
739 | $target->get_source_of()->{$key} = $source; |
---|
740 | } |
---|
741 | } |
---|
742 | else { |
---|
743 | # Source added by diff tree |
---|
744 | my @paths = split($ns_sep, $ns); |
---|
745 | my $dest_list_ref = $DEST->paths( |
---|
746 | $m_ctx, 'target', $ctx->get_id(), @paths, |
---|
747 | ); |
---|
748 | $ctx->get_target_of()->{$ns} = $ctx->CTX_TARGET->new({ |
---|
749 | dests => $dest_list_ref, |
---|
750 | ns => $ns, |
---|
751 | source_of => { |
---|
752 | 0 => $ctx->CTX_SOURCE->new({ |
---|
753 | key_of_tree => 0, |
---|
754 | status => $ctx->CTX_SOURCE->ST_MISSING, |
---|
755 | }), |
---|
756 | $key => $source, |
---|
757 | }, |
---|
758 | }); |
---|
759 | } |
---|
760 | } |
---|
761 | # Handle deleted sources |
---|
762 | while (my ($ns) = each(%sources_deleted)) { |
---|
763 | my $target = $ctx->get_target_of()->{$ns}; |
---|
764 | $target->get_source_of()->{$key} = $ctx->CTX_SOURCE->new({ |
---|
765 | key_of_tree => $key, |
---|
766 | ns => $ns, |
---|
767 | status => $ctx->CTX_SOURCE->ST_MISSING, |
---|
768 | }); |
---|
769 | } |
---|
770 | } |
---|
771 | } |
---|
772 | } |
---|
773 | |
---|
774 | # Extract: compare with previous extract. |
---|
775 | sub _extract_incremental { |
---|
776 | my ($attrib_ref, $m_ctx, $ctx) = @_; |
---|
777 | my $prev_m_ctx = $m_ctx->get_prev_ctx(); |
---|
778 | my $prev_ctx |
---|
779 | = defined($prev_m_ctx) ? $prev_m_ctx->get_ctx_of($ctx->get_id()) |
---|
780 | : undef |
---|
781 | ; |
---|
782 | if (!defined($prev_ctx)) { |
---|
783 | return; |
---|
784 | } |
---|
785 | my %deleted = map {($_ => 1)} keys(%{$prev_ctx->get_target_of()}); |
---|
786 | # Compares the sources in each target |
---|
787 | TARGET: |
---|
788 | while (my ($ns, $target) = each(%{$ctx->get_target_of()})) { |
---|
789 | delete($deleted{$ns}); |
---|
790 | if (!exists($prev_ctx->get_target_of()->{$ns})) { |
---|
791 | next TARGET; |
---|
792 | } |
---|
793 | my $prev_target = $prev_ctx->get_target_of()->{$ns}; |
---|
794 | my %prev_source_of = %{$prev_target->get_source_of()}; |
---|
795 | my %source_of = %{$target->get_source_of()}; |
---|
796 | if (keys(%prev_source_of) != keys(%source_of)) { |
---|
797 | next TARGET; |
---|
798 | } |
---|
799 | while (my ($key_of_tree, $source) = each(%source_of)) { |
---|
800 | if (!exists($prev_source_of{$key_of_tree})) { |
---|
801 | next TARGET; |
---|
802 | } |
---|
803 | my $prev_source = $prev_source_of{$key_of_tree}; |
---|
804 | if ( $prev_source->get_status() ne $source->get_status() |
---|
805 | || !$source->is_missing() && !_source_eq($prev_source, $source) |
---|
806 | ) { |
---|
807 | next TARGET; |
---|
808 | } |
---|
809 | } |
---|
810 | $target->set_status_of_source($prev_target->get_status_of_source()); |
---|
811 | if ($prev_target->is_ok()) { |
---|
812 | $target->set_path($prev_target->get_path()); |
---|
813 | $target->set_status($target->ST_UNCHANGED); |
---|
814 | } |
---|
815 | } |
---|
816 | # Creates a dummy target for each deleted target |
---|
817 | my $ns_sep = $UTIL->ns_sep(); |
---|
818 | while (my $ns = each(%deleted)) { |
---|
819 | my $target = $prev_ctx->get_target_of($ns); |
---|
820 | if ($target->get_status() ne $target->ST_DELETED) { |
---|
821 | my @paths = split($ns_sep, $ns); |
---|
822 | my $dest_list_ref = $attrib_ref->{shared_util_of}{dest}->paths( |
---|
823 | $m_ctx, 'target', $ctx->get_id(), @paths, |
---|
824 | ); |
---|
825 | $ctx->get_target_of()->{$ns} |
---|
826 | = $ctx->CTX_TARGET->new({dests => $dest_list_ref, ns => $ns}); |
---|
827 | } |
---|
828 | } |
---|
829 | } |
---|
830 | |
---|
831 | # Updates the project tree caches. |
---|
832 | sub _project_tree_caches_update { |
---|
833 | my ($attrib_ref, $m_ctx, $ctx) = @_; |
---|
834 | # If previous cache in .tar.gz, extract it |
---|
835 | my $cache_tar_gz = $attrib_ref->{shared_util_of}{dest}->path( |
---|
836 | $m_ctx, 'sys-cache', $ctx->get_id() . '.tar.gz', |
---|
837 | ); |
---|
838 | if (-f $cache_tar_gz) { |
---|
839 | my @command = ( |
---|
840 | qw{tar -x -z}, '-C', dirname($cache_tar_gz), '-f', $cache_tar_gz, |
---|
841 | ); |
---|
842 | my %value_of = %{$UTIL->shell_simple(\@command)}; |
---|
843 | if ($value_of{'rc'} == 0) { |
---|
844 | unlink($cache_tar_gz); |
---|
845 | } |
---|
846 | } |
---|
847 | # Start the parallel task runner to do project tree caches update |
---|
848 | my $timer = $UTIL->timer(); |
---|
849 | my $n_jobs = $m_ctx->get_option_of('jobs'); |
---|
850 | my $n_trees = scalar( |
---|
851 | grep {!$_->get_cache()} |
---|
852 | map {@{$_->get_trees()}} |
---|
853 | values(%{$ctx->get_project_of()}) |
---|
854 | ); |
---|
855 | if ($n_trees == 0) { |
---|
856 | return; |
---|
857 | } |
---|
858 | if ($n_jobs && $n_jobs > $n_trees) { |
---|
859 | $n_jobs = $n_trees; |
---|
860 | } |
---|
861 | my $elapse_tasks = 0; |
---|
862 | my @args = ($attrib_ref, $m_ctx, $ctx); |
---|
863 | my $runner = $UTIL->task_runner( |
---|
864 | sub {_project_tree_cache_update_by_export(@args, @_)}, |
---|
865 | $n_jobs, |
---|
866 | ); |
---|
867 | my $n = eval { |
---|
868 | $runner->main( |
---|
869 | _project_tree_cache_update_get_func(@args), |
---|
870 | _project_tree_cache_update_put_func(@args, \$elapse_tasks), |
---|
871 | ); |
---|
872 | }; |
---|
873 | my $e = $@; |
---|
874 | $runner->destroy(); |
---|
875 | if ($e) { |
---|
876 | _finally($attrib_ref, $m_ctx, $ctx); |
---|
877 | die($e); |
---|
878 | } |
---|
879 | $UTIL->event( |
---|
880 | FCM::Context::Event->MAKE_EXTRACT_RUNNER_SUMMARY, |
---|
881 | 'tree-cache-export', $n, $timer->(), $elapse_tasks, |
---|
882 | ); |
---|
883 | } |
---|
884 | |
---|
885 | # Updates the source cache for a project tree by exporting it. |
---|
886 | sub _project_tree_cache_update_by_export { |
---|
887 | my ($attrib_ref, $m_ctx, $ctx, $tree) = @_; |
---|
888 | my $cache = $tree->get_cache(); |
---|
889 | # Exports the smallest common tree |
---|
890 | my $root_ns; |
---|
891 | SOURCE: |
---|
892 | for my $source (@{$tree->get_sources()}) { |
---|
893 | if ($source->is_unchanged()) { |
---|
894 | next SOURCE; |
---|
895 | } |
---|
896 | if (!defined($root_ns)) { |
---|
897 | $root_ns = $source->get_ns_in_tree(); |
---|
898 | next SOURCE; |
---|
899 | } |
---|
900 | $root_ns = $UTIL->ns_common( |
---|
901 | $root_ns, $source->get_ns_in_tree(), |
---|
902 | ); |
---|
903 | if (!$root_ns) { |
---|
904 | last SOURCE; |
---|
905 | } |
---|
906 | } |
---|
907 | if (!defined($root_ns)) { |
---|
908 | return; |
---|
909 | } |
---|
910 | my $cache_ns = $root_ns ? catfile($cache, $root_ns) : $cache; |
---|
911 | my $locator_ns = $UTIL->loc_cat( |
---|
912 | $tree->get_locator(), split($UTIL->ns_sep(), $root_ns), |
---|
913 | ); |
---|
914 | eval{ |
---|
915 | mkpath(dirname($cache_ns)); |
---|
916 | $UTIL->loc_export($locator_ns, $cache_ns); |
---|
917 | }; |
---|
918 | if (my $e = $@ || !-e $cache_ns && !-l $cache_ns) { |
---|
919 | return $E->throw($E->DEST_CREATE, $cache_ns, $e); |
---|
920 | } |
---|
921 | } |
---|
922 | |
---|
923 | # Generates an iterator for each tree requiring cache update. |
---|
924 | sub _project_tree_cache_update_get_func { |
---|
925 | my ($attrib_ref, $m_ctx, $ctx) = @_; |
---|
926 | my @trees = map {@{$_->get_trees()}} values(%{$ctx->get_project_of()}); |
---|
927 | sub { |
---|
928 | while (my $tree = shift(@trees)) { |
---|
929 | if (!$tree->get_cache()) { |
---|
930 | if ($UTIL->loc_export_ok($tree->get_locator())) { |
---|
931 | my $cache = $attrib_ref->{shared_util_of}{dest}->path( |
---|
932 | $m_ctx, |
---|
933 | 'sys-cache', |
---|
934 | $ctx->get_id(), |
---|
935 | $tree->get_ns(), |
---|
936 | $tree->get_key(), |
---|
937 | ); |
---|
938 | $tree->set_cache($cache); |
---|
939 | rmtree($cache); |
---|
940 | mkpath(dirname($cache)); |
---|
941 | my $id = $tree->get_ns() . '/' . $tree->get_key(); |
---|
942 | return FCM::Context::Task->new({ctx => $tree, id => $id}); |
---|
943 | } |
---|
944 | else { |
---|
945 | $tree->set_cache($tree->get_locator()->get_value()); |
---|
946 | _project_tree_cache_update_sources( |
---|
947 | $attrib_ref, $m_ctx, $ctx, $tree, |
---|
948 | ); |
---|
949 | } |
---|
950 | } |
---|
951 | } |
---|
952 | return; |
---|
953 | }; |
---|
954 | } |
---|
955 | |
---|
956 | # Generates a callback when a tree has a cache. |
---|
957 | sub _project_tree_cache_update_put_func { |
---|
958 | my ($attrib_ref, $m_ctx, $ctx, $elapse_tasks_ref) = @_; |
---|
959 | sub { |
---|
960 | my ($task) = @_; |
---|
961 | if ($task->get_state() eq $task->ST_FAILED) { |
---|
962 | die($task->get_error()); |
---|
963 | } |
---|
964 | my $ns = $task->get_ctx()->get_ns(); |
---|
965 | my $key = $task->get_ctx()->get_key(); |
---|
966 | my $tree = $ctx->get_project_of()->{$ns}->get_trees()->[$key]; |
---|
967 | _project_tree_cache_update_sources($attrib_ref, $m_ctx, $ctx, $tree); |
---|
968 | ${$elapse_tasks_ref} += $task->get_elapse(); |
---|
969 | }; |
---|
970 | } |
---|
971 | |
---|
972 | # Sets the caches of individual project tree sources. |
---|
973 | sub _project_tree_cache_update_sources { |
---|
974 | my ($attrib_ref, $m_ctx, $ctx, $tree) = @_; |
---|
975 | for my $source (@{$tree->get_sources()}) { |
---|
976 | my $cache = catfile( |
---|
977 | $tree->get_cache(), |
---|
978 | split($UTIL->ns_sep(), $source->get_ns_in_tree()), |
---|
979 | ); |
---|
980 | $source->set_cache($cache); |
---|
981 | } |
---|
982 | } |
---|
983 | |
---|
984 | # Handles symbolic links. |
---|
985 | sub _symlink_handle { |
---|
986 | my ($attrib_ref, $m_ctx, $ctx) = @_; |
---|
987 | TARGET: |
---|
988 | while (my ($ns, $target) = each(%{$ctx->get_target_of()})) { |
---|
989 | if ($target->is_unchanged()) { |
---|
990 | next TARGET; |
---|
991 | } |
---|
992 | my $source_hash_ref = $target->get_source_of(); |
---|
993 | # Remove sources that are symbolic links |
---|
994 | while (my ($key, $source) = each(%{$source_hash_ref})) { |
---|
995 | if ($source->get_cache() && -l $source->get_cache()) { |
---|
996 | delete($source_hash_ref->{$key}); |
---|
997 | $UTIL->event( |
---|
998 | FCM::Context::Event->MAKE_EXTRACT_SYMLINK, $source, |
---|
999 | ); |
---|
1000 | } |
---|
1001 | } |
---|
1002 | # It is OK to have a target with no sources, but a target must have a |
---|
1003 | # base source if it has at least one diff source. |
---|
1004 | if ( keys(%{$source_hash_ref}) |
---|
1005 | && !exists($source_hash_ref->{0}) |
---|
1006 | ) { |
---|
1007 | $source_hash_ref->{0} = $ctx->CTX_SOURCE->new( |
---|
1008 | {key_of_tree => 0, status => $ctx->CTX_SOURCE->ST_MISSING}, |
---|
1009 | ); |
---|
1010 | } |
---|
1011 | } |
---|
1012 | } |
---|
1013 | |
---|
1014 | # Updates the targets. |
---|
1015 | sub _targets_update { |
---|
1016 | my ($attrib_ref, $m_ctx, $ctx) = @_; |
---|
1017 | my %basket_of = (status => {}, status_of_source => {}); |
---|
1018 | eval { |
---|
1019 | while (my ($ns, $target) = each(%{$ctx->get_target_of()})) { |
---|
1020 | if ($target->get_status() eq $target->ST_UNKNOWN) { |
---|
1021 | my %source_of = %{$target->get_source_of()}; |
---|
1022 | my $handler |
---|
1023 | = keys(%source_of) ? \&_target_update |
---|
1024 | : \&_target_delete |
---|
1025 | ; |
---|
1026 | $handler->($attrib_ref, $m_ctx, $ctx, $target); |
---|
1027 | my $base = delete($source_of{0}); |
---|
1028 | my @diffs = grep {!$_->is_unchanged()} values(%source_of); |
---|
1029 | $target->set_status_of_source( |
---|
1030 | !keys(%{$target->get_source_of()}) ? $target->ST_UNKNOWN |
---|
1031 | : $base->is_missing() ? $target->ST_ADDED |
---|
1032 | : (grep {$_->is_missing()} @diffs) ? $target->ST_DELETED |
---|
1033 | : scalar(@diffs) > 1 ? $target->ST_MERGED |
---|
1034 | : scalar(@diffs) ? $target->ST_MODIFIED |
---|
1035 | : $target->ST_UNCHANGED |
---|
1036 | ); |
---|
1037 | $UTIL->event( |
---|
1038 | FCM::Context::Event->MAKE_EXTRACT_TARGET, $target, |
---|
1039 | ); |
---|
1040 | } |
---|
1041 | $basket_of{status}{$target->get_status()}++; |
---|
1042 | $basket_of{status_of_source}{$target->get_status_of_source()}++; |
---|
1043 | } |
---|
1044 | }; |
---|
1045 | if (my $e = $@) { |
---|
1046 | _finally($attrib_ref, $m_ctx, $ctx); |
---|
1047 | die($e); |
---|
1048 | } |
---|
1049 | $UTIL->event( |
---|
1050 | FCM::Context::Event->MAKE_EXTRACT_TARGET_SUMMARY, \%basket_of, |
---|
1051 | ); |
---|
1052 | _finally($attrib_ref, $m_ctx, $ctx); |
---|
1053 | } |
---|
1054 | |
---|
1055 | # Updates a deleted target. |
---|
1056 | sub _target_delete { |
---|
1057 | my ($attrib_ref, $m_ctx, $ctx, $target) = @_; |
---|
1058 | my ($dest, @inherited_dests) = @{$target->get_dests()}; |
---|
1059 | if (-f $dest) { |
---|
1060 | unlink($dest) || return $E->throw($E->DEST_CLEAN, $dest, $!); |
---|
1061 | $target->set_status($target->ST_DELETED); |
---|
1062 | } |
---|
1063 | for my $inherited_dest (@inherited_dests) { |
---|
1064 | if (-f $inherited_dest) { |
---|
1065 | $target->set_status($target->ST_O_DELETED); |
---|
1066 | return; |
---|
1067 | } |
---|
1068 | } |
---|
1069 | } |
---|
1070 | |
---|
1071 | # Updates a normal target. |
---|
1072 | sub _target_update { |
---|
1073 | my ($attrib_ref, $m_ctx, $ctx, $target) = @_; |
---|
1074 | my %source_of = %{$target->get_source_of()}; |
---|
1075 | my $source_of_base = delete($source_of{0}); |
---|
1076 | # Either missing source in a diff-tree |
---|
1077 | # Or missing source in base-tree and no diff-trees |
---|
1078 | if ( (grep {$_->is_missing()} values(%source_of)) |
---|
1079 | || $source_of_base->is_missing() && !keys(%source_of) |
---|
1080 | ) { |
---|
1081 | return _target_delete($attrib_ref, $m_ctx, $ctx, $target); |
---|
1082 | } |
---|
1083 | my $path = _target_update_source($attrib_ref, $m_ctx, $ctx, $target); |
---|
1084 | # Note: $path may be a File::Temp object. |
---|
1085 | my ($is_diff, $is_diff_in_perms, $is_in_prev, $rc) = (1, 1, undef, 1); |
---|
1086 | DEST: |
---|
1087 | for my $i (0 .. @{$target->get_dests()} - 1) { |
---|
1088 | my $dest = $target->get_dests()->[$i]; |
---|
1089 | if (-f $dest) { |
---|
1090 | $is_in_prev = $i; |
---|
1091 | ($is_diff_in_perms, $is_diff) = _compare("$path", $dest); |
---|
1092 | last DEST; |
---|
1093 | } |
---|
1094 | } |
---|
1095 | if (!$is_diff && !$is_diff_in_perms) { |
---|
1096 | $target->set_path($target->get_dests()->[$is_in_prev]); |
---|
1097 | $target->set_status($target->ST_UNCHANGED); |
---|
1098 | return; # up to date |
---|
1099 | } |
---|
1100 | my $dest = $target->get_dests()->[0]; |
---|
1101 | if ($is_diff) { |
---|
1102 | my $dest_dir = dirname($dest); |
---|
1103 | if (!-d $dest_dir) { |
---|
1104 | eval {mkpath($dest_dir)}; |
---|
1105 | if (my $e = $@) { |
---|
1106 | return $E->throw($E->DEST_CREATE, $dest_dir, $e); |
---|
1107 | } |
---|
1108 | } |
---|
1109 | copy("$path", $dest) |
---|
1110 | || return $E->throw($E->COPY, ["$path", $dest], $!); |
---|
1111 | } |
---|
1112 | chmod((stat("$path"))[2] & oct(7777), $dest) |
---|
1113 | || return $E->throw($E->DEST_CREATE, $dest, $!); |
---|
1114 | $target->set_path($target->get_dests()->[0]); |
---|
1115 | $target->set_status( |
---|
1116 | $is_in_prev ? $target->ST_O_ADDED |
---|
1117 | : defined($is_in_prev) ? $target->ST_MODIFIED |
---|
1118 | : $target->ST_ADDED |
---|
1119 | ); |
---|
1120 | } |
---|
1121 | |
---|
1122 | # Returns the source path that is to be used to update a target. |
---|
1123 | sub _target_update_source { |
---|
1124 | my ($attrib_ref, $m_ctx, $ctx, $target) = @_; |
---|
1125 | my %source_of = %{$target->get_source_of()}; |
---|
1126 | my $path_of_base = delete($source_of{0})->get_cache(); |
---|
1127 | my @keys_and_paths; |
---|
1128 | while (my ($key, $source) = each(%source_of)) { |
---|
1129 | my $path = $source->get_cache(); |
---|
1130 | if (!$path_of_base || _compare($path_of_base, $path)) { |
---|
1131 | if (!grep {!_compare($_->[1], $path)} @keys_and_paths) { |
---|
1132 | push(@keys_and_paths, [$key, $path]); |
---|
1133 | } |
---|
1134 | } |
---|
1135 | else { |
---|
1136 | $source->set_status($source->ST_UNCHANGED); |
---|
1137 | } |
---|
1138 | } |
---|
1139 | my @args = ( |
---|
1140 | $m_ctx, $ctx, $target, $path_of_base, |
---|
1141 | (sort {$a->[0] <=> $b->[0]} @keys_and_paths), |
---|
1142 | ); |
---|
1143 | return ( |
---|
1144 | @keys_and_paths == 0 ? $path_of_base |
---|
1145 | : @keys_and_paths == 1 ? $keys_and_paths[0][1] |
---|
1146 | : _target_update_source_merge($attrib_ref, @args) |
---|
1147 | ); |
---|
1148 | } |
---|
1149 | |
---|
1150 | # Merges changes in contents of paths in @keys_and_paths against content in |
---|
1151 | # $path_of_base. |
---|
1152 | sub _target_update_source_merge { |
---|
1153 | my ($attrib_ref, $m_ctx, $ctx, $target, $path_of_base, @keys_and_paths) = @_; |
---|
1154 | if (!$path_of_base) { |
---|
1155 | $path_of_base = File::Temp->new(); |
---|
1156 | if (!defined($path_of_base) || !close($path_of_base)) { |
---|
1157 | return $E->throw($E->DEST_CREATE, tmpdir(), $!); |
---|
1158 | } |
---|
1159 | } |
---|
1160 | my ($key_of_mine, $path_of_mine) = @{shift(@keys_and_paths)}; |
---|
1161 | my @keys_done = ($key_of_mine); |
---|
1162 | while (my $key_and_path = shift(@keys_and_paths)) { |
---|
1163 | my ($key, $path) = @{$key_and_path}; |
---|
1164 | my @command = ( |
---|
1165 | (map {_props($attrib_ref, $_, $ctx)} qw{diff3 diff3.flags}), |
---|
1166 | "$path_of_mine", "$path_of_base", $path, |
---|
1167 | ); |
---|
1168 | my %value_of = %{$UTIL->shell_simple(\@command)}; |
---|
1169 | if ($value_of{rc} && $value_of{rc} == 1) { |
---|
1170 | # Write conflict output to .fcm-make/extract/conflict/$NS |
---|
1171 | my $file = $attrib_ref->{shared_util_of}{dest}->path( |
---|
1172 | $m_ctx, 'sys', $ctx->get_id(), 'merge', |
---|
1173 | $target->get_ns() . '.diff', |
---|
1174 | ); |
---|
1175 | $UTIL->file_save($file, $value_of{o}); |
---|
1176 | return $E->throw($E->EXTRACT_MERGE, { |
---|
1177 | 'target' => $target, |
---|
1178 | 'output' => $file, |
---|
1179 | 'keys_done' => \@keys_done, |
---|
1180 | 'key' => $key, |
---|
1181 | 'keys_left' => [map {$_->[0]} @keys_and_paths], |
---|
1182 | }); |
---|
1183 | } |
---|
1184 | elsif ($value_of{rc}) { |
---|
1185 | return $E->throw( |
---|
1186 | $E->SHELL, {command_list => \@command, %value_of}, $value_of{e}, |
---|
1187 | ); |
---|
1188 | } |
---|
1189 | my $perm = (stat("$path_of_mine"))[2] & 07777 | (stat($path))[2] & 07777; |
---|
1190 | for my $action ( |
---|
1191 | sub {$path_of_mine = File::Temp->new()}, |
---|
1192 | sub {print({$path_of_mine} $value_of{o})}, |
---|
1193 | sub {close($path_of_mine)}, |
---|
1194 | sub {chmod($perm, "$path_of_mine")}, |
---|
1195 | ) { |
---|
1196 | $action->() || return $E->throw($E->DEST_CREATE, "$path_of_mine", $!); |
---|
1197 | } |
---|
1198 | push(@keys_done, $key); |
---|
1199 | } |
---|
1200 | return $path_of_mine; |
---|
1201 | } |
---|
1202 | |
---|
1203 | # Perform final actions. |
---|
1204 | # Archive cache directory if necessary. |
---|
1205 | sub _finally { |
---|
1206 | my ($attrib_ref, $m_ctx, $ctx) = @_; |
---|
1207 | if (!$m_ctx->get_option_of('archive')) { |
---|
1208 | return; |
---|
1209 | } |
---|
1210 | my $cache = $attrib_ref->{shared_util_of}{dest}->path( |
---|
1211 | $m_ctx, 'sys-cache', $ctx->get_id(), |
---|
1212 | ); |
---|
1213 | if (-d $cache) { |
---|
1214 | my @command = ( |
---|
1215 | qw{tar -c -z}, '-C', dirname($cache), '-f', $cache . '.tar.gz', |
---|
1216 | $ctx->get_id(), |
---|
1217 | ); |
---|
1218 | my %value_of = %{$UTIL->shell_simple(\@command)}; |
---|
1219 | if ($value_of{'rc'} == 0) { |
---|
1220 | rmtree($cache); |
---|
1221 | } |
---|
1222 | } |
---|
1223 | } |
---|
1224 | |
---|
1225 | # In scalar context, returns true if the contents or permissions of 2 paths |
---|
1226 | # differ. In array context, returns ($is_diff_in_perms, $is_diff_in_content). |
---|
1227 | sub _compare { |
---|
1228 | my ($path1, $path2) = @_; |
---|
1229 | my $is_diff_in_perms = (stat($path1))[2] != (stat($path2))[2]; |
---|
1230 | wantarray() |
---|
1231 | ? ($is_diff_in_perms, compare($path1, $path2)) |
---|
1232 | : ($is_diff_in_perms || compare($path1, $path2)) |
---|
1233 | ; |
---|
1234 | } |
---|
1235 | |
---|
1236 | # Returns true if two sources are the same or if their latest modified revisions |
---|
1237 | # are the same. |
---|
1238 | sub _source_eq { |
---|
1239 | my ($source1, $source2) = @_; |
---|
1240 | my ($locator1, $locator2) = map {$_->get_locator()} ($source1, $source2); |
---|
1241 | # Compares their value + mtime or their last modified revision |
---|
1242 | $locator1->get_value() eq $locator2->get_value() |
---|
1243 | && defined($locator1->get_last_mod_time()) |
---|
1244 | && defined($locator2->get_last_mod_time()) |
---|
1245 | && $locator1->get_last_mod_time() eq $locator2->get_last_mod_time() |
---|
1246 | || defined($locator1->get_last_mod_rev()) |
---|
1247 | && defined($locator2->get_last_mod_rev()) |
---|
1248 | && $locator1->get_last_mod_rev() eq $locator2->get_last_mod_rev() |
---|
1249 | ; |
---|
1250 | } |
---|
1251 | |
---|
1252 | # ------------------------------------------------------------------------------ |
---|
1253 | 1; |
---|
1254 | __END__ |
---|
1255 | |
---|
1256 | =head1 NAME |
---|
1257 | |
---|
1258 | FCM::System::Make::Extract |
---|
1259 | |
---|
1260 | =head1 SYNOPSIS |
---|
1261 | |
---|
1262 | use FCM::System::Make::Extract; |
---|
1263 | my $extract = FCM::System::Make::Extract->new(\%attrib); |
---|
1264 | $extract->($m_ctx, $ctx); |
---|
1265 | |
---|
1266 | =head1 DESCRIPTION |
---|
1267 | |
---|
1268 | Implements the extract sub-system. An instance of this class is expected to be |
---|
1269 | initialised and called by L<FCM::System::Make|FCM::System::Make>. |
---|
1270 | |
---|
1271 | =head1 METHODS |
---|
1272 | |
---|
1273 | See L<FCM::System::Make|FCM::System::Make> for detail. |
---|
1274 | |
---|
1275 | =head1 ATTRIBUTES |
---|
1276 | |
---|
1277 | The $class->new(\%attrib) method of this class supports the following |
---|
1278 | attributes: |
---|
1279 | |
---|
1280 | =over 4 |
---|
1281 | |
---|
1282 | =item config_parser_of |
---|
1283 | |
---|
1284 | A HASH to map the labels in a configuration file to their parsers. (default = |
---|
1285 | %FCM::System::Make::Extract::CONFIG_PARSER_OF) |
---|
1286 | |
---|
1287 | =item prop_of |
---|
1288 | |
---|
1289 | A HASH to map the names of the properties to their settings. Each setting |
---|
1290 | is a 2-element ARRAY reference, where element [0] is the default setting |
---|
1291 | and element [1] is a flag to indicate whether the property accepts a name-space |
---|
1292 | or not. (default = %FCM::System::Make::Extract::PROP_OF) |
---|
1293 | |
---|
1294 | =item shared_util_of |
---|
1295 | |
---|
1296 | See L<FCM::System::Make|FCM::System::Make> for detail. |
---|
1297 | |
---|
1298 | =item util |
---|
1299 | |
---|
1300 | See L<FCM::System::Make|FCM::System::Make> for detail. |
---|
1301 | |
---|
1302 | =back |
---|
1303 | |
---|
1304 | =head1 TODO |
---|
1305 | |
---|
1306 | Handle alternate method of merge (e.g. Algorithm::Merge). |
---|
1307 | |
---|
1308 | =head1 COPYRIGHT |
---|
1309 | |
---|
1310 | Copyright (C) 2006-2021 British Crown (Met Office) & Contributors. |
---|
1311 | |
---|
1312 | =cut |
---|