# ------------------------------------------------------------------------------
# Copyright (C) 2006-2021 British Crown (Met Office) & Contributors.
#
# This file is part of FCM, tools for managing and building source code.
#
# FCM is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# FCM is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with FCM. If not, see .
# ------------------------------------------------------------------------------
use strict;
use warnings;
# ------------------------------------------------------------------------------
package FCM::System::Make::Extract;
use base qw{FCM::Class::CODE};
use FCM::Context::ConfigEntry;
use FCM::Context::Event;
use FCM::Context::Make::Extract;
use FCM::Context::Locator;
use FCM::Context::Task;
use FCM::System::Exception;
use FCM::System::Make::Share::Subsystem;
use File::Basename qw{dirname};
use File::Compare qw{compare};
use File::Copy qw{copy};
use File::Path qw{mkpath rmtree};
use File::Spec::Functions qw{abs2rel catfile tmpdir};
use File::Temp;
use List::Util qw{first};
use Storable qw{dclone};
# Aliases
our $UTIL;
my $E = 'FCM::System::Exception';
# Configuration parser map: label to action
our %CONFIG_PARSER_OF = (
'location' => \&_config_parse_location,
'ns' => \&_config_parse_ns_list,
'path-excl' => _config_parse_path_func(
sub {$_->get_path_excl()}, sub {$_->set_path_excl(@_)}, '@',
),
'path-incl' => _config_parse_path_func(
sub {$_->get_path_incl()}, sub {$_->set_path_incl(@_)}, '@',
),
'path-root' => _config_parse_path_func(
sub {$_->get_path_root()}, sub {$_->set_path_root(@_)},
),
);
# Properties from FCM::Util
our @UTIL_PROP_KEYS = qw{diff3 diff3.flags};
# Creates the class.
__PACKAGE__->class(
{ config_parser_of => {isa => '%', default => {%CONFIG_PARSER_OF}},
prop_of => '%',
shared_util_of => '%',
util => '&',
},
{ init => \&_init,
action_of => {
config_parse => \&_config_parse,
config_parse_class_prop => \&_config_parse_class_prop,
config_parse_inherit_hook => \&_config_parse_inherit_hook,
config_unparse => \&_config_unparse,
config_unparse_class_prop => \&_config_unparse_class_prop,
ctx => \&_ctx,
ctx_load_hook => \&_ctx_load_hook,
main => \&_main,
},
},
);
# Initialises the helpers of the class.
sub _init {
my ($attrib_ref) = @_;
for my $util_prop_key (@UTIL_PROP_KEYS) {
my $prop = $attrib_ref->{util}->external_cfg_get($util_prop_key);
$attrib_ref->{prop_of}{$util_prop_key} = [$prop];
}
}
# Reads the extract.location declaration from a config entry.
sub _config_parse_location {
my ($attrib_ref, $ctx, $entry) = @_;
if (!@{$entry->get_ns_list()}) {
return $E->throw($E->CONFIG_NS, $entry);
}
my %PARSER_OF = (
'base' => \&_config_parse_location_base,
'diff' => \&_config_parse_location_diff,
'primary' => \&_config_parse_location_primary,
);
my %modifier_of = %{$entry->get_modifier_of()};
if (!grep {exists($modifier_of{$_})} keys(%PARSER_OF)) {
$modifier_of{'base'} = 1;
}
for my $key (grep {exists($modifier_of{$_})} keys(%PARSER_OF)) {
$PARSER_OF{$key}->($attrib_ref, $ctx, $entry);
}
}
# Reads the extract.location{base} declaration from a config entry.
sub _config_parse_location_base {
my ($attrib_ref, $ctx, $entry) = @_;
my %option;
if (exists($entry->get_modifier_of()->{'type'})) {
%option = ('type' => $entry->get_modifier_of()->{'type'});
}
for my $ns (@{$entry->get_ns_list()}) {
if (!exists($ctx->get_project_of()->{$ns})) {
$ctx->get_project_of()->{$ns} = $ctx->CTX_PROJECT->new({ns => $ns});
}
my $project = $ctx->get_project_of()->{$ns};
if ($project->get_inherited()) {
if (!$entry->get_value()) {
return $E->throw($E->CONFIG_VALUE, $entry);
}
my $locator = FCM::Context::Locator->new(
$entry->get_value(), \%option,
);
if ($project->get_locator()) {
$attrib_ref->{util}->loc_rel2abs(
$locator,
$project->get_locator(),
);
}
$attrib_ref->{util}->loc_as_invariant($locator);
my $i_locator = $project->get_trees()->[0]->get_locator();
if ($locator->get_value() ne $i_locator->get_value()) {
return $E->throw($E->CONFIG_CONFLICT, $entry);
}
}
else {
if ( !exists($project->get_trees()->[0])
|| !defined($project->get_trees()->[0])
) {
$project->get_trees()->[0]
= $ctx->CTX_TREE->new({key => 0, ns => $ns});
}
if ($entry->get_value()) {
my $locator = FCM::Context::Locator->new(
$entry->get_value(), \%option,
);
$project->get_trees()->[0]->set_locator($locator);
}
else {
$project->get_trees()->[0] = undef;
}
}
}
}
# Reads the extract.location{diff} declaration from a config entry.
sub _config_parse_location_diff {
my ($attrib_ref, $ctx, $entry) = @_;
my %option;
if (exists($entry->get_modifier_of()->{'type'})) {
%option = ('type' => $entry->get_modifier_of()->{'type'});
}
for my $ns (@{$entry->get_ns_list()}) {
if (!exists($ctx->get_project_of()->{$ns})) {
$ctx->get_project_of()->{$ns} = $ctx->CTX_PROJECT->new({ns => $ns});
}
my $project = $ctx->get_project_of()->{$ns};
my ($base, @diffs) = @{$project->get_trees()};
@diffs = grep {
$_->get_inherited()
|| $option{type}
&& $_->get_locator()->get_type()
&& $option{type} ne $_->get_locator()->get_type()
} @diffs;
for my $value ($entry->get_values()) {
if (!$value) {
return $E->throw($E->CONFIG_VALUE, $entry);
}
push(
@diffs,
$ctx->CTX_TREE->new({
key => scalar(@diffs) + 1,
locator => FCM::Context::Locator->new($value, \%option),
ns => $ns,
}),
);
}
@{$project->get_trees()} = ($base, @diffs);
}
}
# Reads the extract.location{primary} declaration from a config entry.
sub _config_parse_location_primary {
my ($attrib_ref, $ctx, $entry) = @_;
my %option;
if (exists($entry->get_modifier_of()->{'type'})) {
%option = ('type' => $entry->get_modifier_of()->{'type'});
}
for my $ns (@{$entry->get_ns_list()}) {
if (!exists($ctx->get_project_of()->{$ns})) {
$ctx->get_project_of()->{$ns} = $ctx->CTX_PROJECT->new({ns => $ns});
}
my $project = $ctx->get_project_of()->{$ns};
if ($entry->get_value()) {
my $locator = FCM::Context::Locator->new(
$entry->get_value(), \%option,
);
$attrib_ref->{util}->loc_as_normalised($locator);
if ($project->get_inherited()) {
my $project_locator = $project->get_locator();
if ($project_locator->get_value() ne $locator->get_value()) {
return $E->throw($E->CONFIG_CONFLICT, $entry);
}
}
else {
$project->set_locator($locator);
}
}
else {
$project->set_locator(undef);
}
}
}
# Reads the extract.ns declaration from a config entry.
sub _config_parse_ns_list {
my ($attrib_ref, $ctx, $entry) = @_;
@{$ctx->get_ns_list()} = $entry->get_values();
}
# Returns a function to parse extract.path-*.
sub _config_parse_path_func {
my ($getter, $setter, $isa) = @_;
$isa ||= '$';
sub {
my ($attrib_ref, $ctx, $entry) = @_;
my @ns_list
= @{$entry->get_ns_list()} ? @{$entry->get_ns_list()}
: @{$ctx->get_ns_list()}
;
for my $ns (@ns_list) {
if (!exists($ctx->get_project_of()->{$ns})) {
$ctx->get_project_of()->{$ns}
= $ctx->CTX_PROJECT->new({ns => $ns});
}
my $project = $ctx->get_project_of()->{$ns};
my $value = $entry->get_value();
if ($isa eq '@') {
$value = [map {$_ eq q{/} ? q{} : $_} $entry->get_values()];
}
local($_) = $project;
if ($_->get_inherited()) {
my $old = $getter->();
my $new = $value;
if ($isa eq '@') {
$old = _config_unparse_join(@{$old});
$new = _config_unparse_join(@{$new});
}
if ($old ne $new) {
return $E->throw($E->CONFIG_CONFLICT, $entry);
}
}
else {
$setter->($value);
}
}
};
}
# A hook command for the "inherit/use" declaration.
sub _config_parse_inherit_hook {
my ($attrib_ref, $ctx, $i_ctx) = @_;
@{$ctx->get_ns_list()} = @{$i_ctx->get_ns_list()};
while (my ($ns, $i_project) = each(%{$i_ctx->get_project_of()})) {
my $project = dclone($i_project);
$project->set_inherited(1);
for my $tree (@{$project->get_trees()}) {
$tree->set_inherited(1);
}
$ctx->get_project_of()->{$ns} = $project;
}
_config_parse_inherit_hook_prop($attrib_ref, $ctx, $i_ctx);
}
# Turns a context into a list of configuration entries.
sub _config_unparse {
my ($attrib_ref, $ctx) = @_;
my %LABEL_OF
= map {($_ => $ctx->get_id() . q{.} . $_)} keys(%CONFIG_PARSER_OF);
my @entries = (
FCM::Context::ConfigEntry->new({
label => $LABEL_OF{ns},
value => _config_unparse_join(@{$ctx->get_ns_list()}),
}),
);
for my $p_ns (sort keys(%{$ctx->get_project_of()})) {
my $project = $ctx->get_project_of($p_ns);
my ($base, @diffs) = @{$project->get_trees()};
if (!$project->get_inherited()) {
if (defined($project->get_locator())) {
my $locator = $project->get_locator();
my %modifier_of = (primary => 1, type => $locator->get_type());
push(
@entries,
FCM::Context::ConfigEntry->new({
label => $LABEL_OF{location},
modifier_of => \%modifier_of,
ns_list => [$p_ns],
value => $locator->get_value(),
}),
);
}
if (@{$project->get_path_excl()}) {
my @values = map {$_ ? $_ : q{/}} @{$project->get_path_excl()};
push(
@entries,
FCM::Context::ConfigEntry->new({
label => $LABEL_OF{'path-excl'},
ns_list => [$p_ns],
value => _config_unparse_join(@values),
}),
);
}
if (@{$project->get_path_incl()}) {
my @values = map {$_ ? $_ : q{/}} @{$project->get_path_incl()};
push(
@entries,
FCM::Context::ConfigEntry->new({
label => $LABEL_OF{'path-incl'},
ns_list => [$p_ns],
value => _config_unparse_join(@values),
}),
);
}
if ($project->get_path_root()) {
push(
@entries,
FCM::Context::ConfigEntry->new({
label => $LABEL_OF{'path-root'},
ns_list => [$p_ns],
value => $project->get_path_root(),
}),
);
}
my $value = $base->get_locator()->get_value();
push(
@entries,
FCM::Context::ConfigEntry->new({
label => $LABEL_OF{'location'},
modifier_of => {type => $base->get_locator()->get_type()},
ns_list => [$p_ns],
value => $value,
}),
);
}
@diffs = grep {!$_->get_inherited()} @diffs;
if (@diffs) {
my %type_set = map {($_->get_locator()->get_type() => 1)} @diffs;
for my $type (sort(keys(%type_set))) {
my $value = _config_unparse_join(
map {$_->get_locator()->get_value()}
grep {$_->get_locator()->get_type() eq $type}
@diffs
);
push(
@entries,
FCM::Context::ConfigEntry->new({
label => $LABEL_OF{'location'},
modifier_of => {diff => 1, type => $type},
ns_list => [$p_ns],
value => $value,
}),
);
}
}
}
push(@entries, _config_unparse_prop($attrib_ref, $ctx));
return @entries;
}
# Returns a new context.
sub _ctx {
my ($attrib_ref, $id_of_class, $id) = @_;
FCM::Context::Make::Extract->new({id => $id, id_of_class => $id_of_class});
}
# Hook when loading a previous ctx.
sub _ctx_load_hook {
my ($attrib_ref, $old_m_ctx, $old_ctx, $old_m_dest, $old_dest) = @_;
my $path_mod_func = sub {
my ($get_func, $set_func) = @_;
my $path = $get_func->();
if (!defined($path)) {
return;
}
my $rel_path = abs2rel($path, $old_m_dest);
if (index($rel_path, '..') != 0) {
$set_func->(catfile($old_m_ctx->get_dest(), $rel_path));
}
};
while (my ($ns, $project) = each(%{$old_ctx->get_project_of()})) {
$path_mod_func->(
sub {$project->get_cache()},
sub {$project->set_cache(@_)},
);
for my $tree (@{$project->get_trees()}) {
$path_mod_func->(
sub {$tree->get_cache()},
sub {$tree->set_cache(@_)},
);
for my $source (@{$tree->get_sources()}) {
$path_mod_func->(
sub {$source->get_cache()},
sub {$source->set_cache(@_)},
);
}
}
}
while (my ($key, $target) = each(%{$old_ctx->get_target_of()})) {
$path_mod_func->(
sub {$target->get_path()},
sub {$target->set_path(@_)},
);
$path_mod_func->(
sub {$target->get_dests()->[0]},
sub {$target->get_dests()->[0] = $_[0]},
);
while (my ($ns, $source) = each(%{$target->get_source_of()})) {
$path_mod_func->(
sub {$source->get_cache()},
sub {$source->set_cache(@_)},
);
}
}
}
# The main function of this class.
sub _main {
my ($attrib_ref, $m_ctx, $ctx) = @_;
local($UTIL) = $attrib_ref->{util};
for my $function (
\&_elaborate_ctx_of_project,
\&_elaborate_ctx_of_target,
\&_extract_incremental,
\&_project_tree_caches_update,
\&_symlink_handle,
\&_targets_update,
) {
$function->($attrib_ref, $m_ctx, $ctx);
}
}
# Elaborates the context: project and tree.
sub _elaborate_ctx_of_project {
my ($attrib_ref, $m_ctx, $ctx) = @_;
# Reports projects that are not used
my @bad_ns_list;
while (my ($p_ns, $project) = each(%{$ctx->get_project_of()})) {
if ( !$project->get_inherited()
&& !grep {$_ eq $p_ns} @{$ctx->get_ns_list()}
) {
push(@bad_ns_list, $p_ns);
}
}
if (@bad_ns_list) {
return $E->throw($E->EXTRACT_NS, \@bad_ns_list);
}
# Determines a list of new trees
my $prev_m_ctx = $m_ctx->get_prev_ctx();
my $prev_ctx
= defined($prev_m_ctx) ? $prev_m_ctx->get_ctx_of($ctx->get_id())
: undef
;
my @trees; # list of new trees
for my $p_ns (@{$ctx->get_ns_list()}) {
# Ensures the project settings are defined
if (!exists($ctx->get_project_of()->{$p_ns})) {
$ctx->get_project_of()->{$p_ns}
= $ctx->CTX_PROJECT->new({ns => $p_ns});
}
my $project = $ctx->get_project_of()->{$p_ns};
# Determine the root location of the project, if possible
if (defined($project->get_locator())) {
$UTIL->loc_as_normalised($project->get_locator());
}
else {
my $uri = $UTIL->loc_kw_prefix() . ':' . $p_ns;
my $locator = FCM::Context::Locator->new($uri);
local($@);
eval {$UTIL->loc_as_normalised($locator)};
if (!$@) {
$project->set_locator($locator);
}
}
# Ensures base tree is defined
if (!@{$project->get_trees()} || !defined($project->get_trees()->[0])) {
if (!defined($project->get_locator())) {
return $E->throw($E->EXTRACT_LOC_BASE, $p_ns);
}
my $head_locator = $UTIL->loc_trunk_at_head($project->get_locator());
my $locator
= $head_locator ? $head_locator
: dclone($project->get_locator())
;
$project->get_trees()->[0] = $ctx->CTX_TREE->new(
{key => 0, locator => $locator, ns => $p_ns},
);
}
# Determine whether there is a usable previous extract
my %path_excl = map {($_, 1)} @{$project->get_path_excl()};
my %path_incl = map {($_, 1)} @{$project->get_path_incl()};
my $path_root = $project->get_path_root();
my ($can_use_prev, $prev_project);
if (defined($prev_ctx) && defined($prev_ctx->get_project_of($p_ns))) {
$prev_project = $prev_ctx->get_project_of($p_ns);
my %prev_path_excl = map {($_, 1)} @{$prev_project->get_path_excl()};
my %prev_path_incl = map {($_, 1)} @{$prev_project->get_path_incl()};
my $prev_path_root = $prev_project->get_path_root();
$can_use_prev
= $prev_ctx->get_status() eq $m_ctx->ST_OK
&& !$UTIL->hash_cmp(\%path_excl, \%prev_path_excl, 1)
&& !$UTIL->hash_cmp(\%path_incl, \%prev_path_incl, 1)
&& $path_root eq $prev_path_root
;
}
# Tree locators as invariant
TREE:
for my $tree (grep {!$_->get_inherited()} @{$project->get_trees()}) {
my $tree_locator = $tree->get_locator();
# Ensures that the tree locator is an absolute path
if (defined($project->get_locator())) {
$UTIL->loc_rel2abs($tree_locator, $project->get_locator());
}
# Determines invariant form of the locator of the project tree.
$UTIL->loc_as_invariant($tree_locator);
}
# Remove diff trees that are the same as the base tree
my ($base_tree, @old_diff_trees) = @{$project->get_trees()};
my $base_value = $base_tree->get_locator()->get_value();
my @new_diff_trees;
TREE:
for my $tree (@old_diff_trees) {
if ($base_value ne $tree->get_locator()->get_value()) {
push(@new_diff_trees, $tree);
$tree->set_key(scalar(@new_diff_trees)); # reset key (index)
}
}
$project->set_trees([$base_tree, @new_diff_trees]);
# Determine the new trees
TREE:
for my $tree (grep {!$_->get_inherited()} @{$project->get_trees()}) {
my $tree_locator = $tree->get_locator();
if ( $can_use_prev
&& $tree_locator->get_value_level() >= $tree_locator->L_INVARIANT
) {
my $prev_tree = first {
$tree_locator->get_value() eq $_->get_locator()->get_value()
} @{$prev_project->get_trees()};
if ($prev_tree) {
my $prev_tree_locator = $prev_tree->get_locator();
$tree->set_sources($prev_tree->get_sources());
if ($tree->get_key() || !$prev_tree->get_key()) {
# Only safe to re-use cache if both are base trees
# or for diff tree with an unchanged base tree
$tree->set_cache($prev_tree->get_cache());
}
next TREE;
}
if (!$tree->get_key()) { # base tree changed
$can_use_prev = 0;
}
}
push(@trees, $tree); # new tree
}
}
# Obtain source info for each new tree, using the task runner
if (@trees) {
my $timer = $UTIL->timer();
my $n_jobs = $m_ctx->get_option_of('jobs');
if ($n_jobs && $n_jobs > scalar(@trees)) {
$n_jobs = scalar(@trees);
}
my $elapse_tasks = 0;
my $runner = $UTIL->task_runner(
sub {_elaborate_ctx_of_project_tree($attrib_ref, $m_ctx, $ctx, @_)},
$n_jobs,
);
my $n = eval {
$runner->main(
# get
sub {
if (!@trees) {
return;
}
my $tree = shift(@trees);
my $id = join(':', $tree->get_ns(), $tree->get_key());
FCM::Context::Task->new({ctx => $tree, id => $id});
},
# put
sub {
my ($task) = @_;
if ($task->get_state() eq $task->ST_FAILED) {
die($task->get_error());
}
my $ns = $task->get_ctx()->get_ns();
my $key = $task->get_ctx()->get_key();
my $project = $ctx->get_project_of()->{$ns};
my $tree = $project->get_trees()->[$key];
$tree->set_locator($task->get_ctx()->get_locator());
$tree->set_sources($task->get_ctx()->get_sources());
$elapse_tasks += $task->get_elapse();
},
);
};
my $e = $@;
$runner->destroy();
if ($e) {
die($e);
}
$UTIL->event(
FCM::Context::Event->MAKE_EXTRACT_RUNNER_SUMMARY,
'tree-sources-info-get', $n, $timer->(), $elapse_tasks,
);
}
$UTIL->event(
FCM::Context::Event->MAKE_EXTRACT_PROJECT_TREE,
{ map {($_ => [
map {$_->get_locator()}
@{$ctx->get_project_of()->{$_}->get_trees()}
])}
sort keys(%{$ctx->get_project_of()})
},
);
}
# Elaborates the context: new tree in a project.
sub _elaborate_ctx_of_project_tree {
my ($attrib_ref, $m_ctx, $ctx, $tree) = @_;
my $project = $ctx->get_project_of()->{$tree->get_ns()};
my $path_root = $project->get_path_root();
# TODO: support regular expression or wildcards?
my %path_incl = map {($_ => 1)} @{$project->get_path_incl()};
my %path_excl = map {($_ => 1)} @{$project->get_path_excl()};
$UTIL->loc_find(
$tree->get_locator(),
sub {
my ($locator, $locator_attrib_ref) = @_;
if ($locator_attrib_ref->{is_dir}) {
return;
}
my $ns_in_tree = $locator_attrib_ref->{ns};
my $ns = $ns_in_tree;
if ($path_root) {
if ($path_root ne $UTIL->ns_common($path_root, $ns)) {
return;
}
$ns = $ns eq $path_root ? q{}
: substr($ns, length($path_root) + 1)
;
}
my $ns_iter_ref = $UTIL->ns_iter($ns, $UTIL->NS_ITER_UP);
NS:
while (defined(my $head = $ns_iter_ref->())) {
if (exists($path_incl{$head})) {
last NS;
}
if (exists($path_excl{$head})) {
return;
}
}
push(
@{$tree->get_sources()},
$ctx->CTX_SOURCE->new({
key_of_tree => $tree->get_key(),
locator => $locator,
ns => $UTIL->ns_cat($tree->get_ns(), $ns),
ns_in_tree => $ns_in_tree,
}),
);
},
);
$tree;
}
# Elaborates the context: target.
sub _elaborate_ctx_of_target {
my ($attrib_ref, $m_ctx, $ctx) = @_;
# Works out the extract sources and targets
my $DEST = $attrib_ref->{shared_util_of}{dest};
my $ns_sep = $UTIL->ns_sep();
while (my ($p_ns, $project) = each(%{$ctx->get_project_of()})) {
my ($tree_base, @trees) = @{$project->get_trees()};
# Sources from the base tree
for my $source (@{$tree_base->get_sources()}) {
my $ns = $source->get_ns();
my @paths = split($ns_sep, $ns);
my $dest_list_ref = $DEST->paths(
$m_ctx, 'target', $ctx->get_id(), @paths
);
$ctx->get_target_of()->{$ns} = $ctx->CTX_TARGET->new({
dests => $dest_list_ref,
ns => $ns,
source_of => {$tree_base->get_key() => $source},
});
}
my %sources_in_base
= map {($_->get_ns() => $_)} @{$tree_base->get_sources()};
# Sources from the diff trees
for my $tree (@trees) {
my $key = $tree->get_key();
my %sources_deleted = %sources_in_base;
# Handles new/modified sources
for my $source (@{$tree->get_sources()}) {
my $ns = $source->get_ns();
delete($sources_deleted{$ns});
if (exists($ctx->get_target_of()->{$ns})) {
my $target = $ctx->get_target_of()->{$ns};
my $base_source = $target->get_source_of()->{0};
if ( $base_source->get_locator()
&& _source_eq($base_source, $source)
) {
$source->set_status($source->ST_UNCHANGED);
}
else {
# Source modified by diff tree
$target->get_source_of()->{$key} = $source;
}
}
else {
# Source added by diff tree
my @paths = split($ns_sep, $ns);
my $dest_list_ref = $DEST->paths(
$m_ctx, 'target', $ctx->get_id(), @paths,
);
$ctx->get_target_of()->{$ns} = $ctx->CTX_TARGET->new({
dests => $dest_list_ref,
ns => $ns,
source_of => {
0 => $ctx->CTX_SOURCE->new({
key_of_tree => 0,
status => $ctx->CTX_SOURCE->ST_MISSING,
}),
$key => $source,
},
});
}
}
# Handle deleted sources
while (my ($ns) = each(%sources_deleted)) {
my $target = $ctx->get_target_of()->{$ns};
$target->get_source_of()->{$key} = $ctx->CTX_SOURCE->new({
key_of_tree => $key,
ns => $ns,
status => $ctx->CTX_SOURCE->ST_MISSING,
});
}
}
}
}
# Extract: compare with previous extract.
sub _extract_incremental {
my ($attrib_ref, $m_ctx, $ctx) = @_;
my $prev_m_ctx = $m_ctx->get_prev_ctx();
my $prev_ctx
= defined($prev_m_ctx) ? $prev_m_ctx->get_ctx_of($ctx->get_id())
: undef
;
if (!defined($prev_ctx)) {
return;
}
my %deleted = map {($_ => 1)} keys(%{$prev_ctx->get_target_of()});
# Compares the sources in each target
TARGET:
while (my ($ns, $target) = each(%{$ctx->get_target_of()})) {
delete($deleted{$ns});
if (!exists($prev_ctx->get_target_of()->{$ns})) {
next TARGET;
}
my $prev_target = $prev_ctx->get_target_of()->{$ns};
my %prev_source_of = %{$prev_target->get_source_of()};
my %source_of = %{$target->get_source_of()};
if (keys(%prev_source_of) != keys(%source_of)) {
next TARGET;
}
while (my ($key_of_tree, $source) = each(%source_of)) {
if (!exists($prev_source_of{$key_of_tree})) {
next TARGET;
}
my $prev_source = $prev_source_of{$key_of_tree};
if ( $prev_source->get_status() ne $source->get_status()
|| !$source->is_missing() && !_source_eq($prev_source, $source)
) {
next TARGET;
}
}
$target->set_status_of_source($prev_target->get_status_of_source());
if ($prev_target->is_ok()) {
$target->set_path($prev_target->get_path());
$target->set_status($target->ST_UNCHANGED);
}
}
# Creates a dummy target for each deleted target
my $ns_sep = $UTIL->ns_sep();
while (my $ns = each(%deleted)) {
my $target = $prev_ctx->get_target_of($ns);
if ($target->get_status() ne $target->ST_DELETED) {
my @paths = split($ns_sep, $ns);
my $dest_list_ref = $attrib_ref->{shared_util_of}{dest}->paths(
$m_ctx, 'target', $ctx->get_id(), @paths,
);
$ctx->get_target_of()->{$ns}
= $ctx->CTX_TARGET->new({dests => $dest_list_ref, ns => $ns});
}
}
}
# Updates the project tree caches.
sub _project_tree_caches_update {
my ($attrib_ref, $m_ctx, $ctx) = @_;
# If previous cache in .tar.gz, extract it
my $cache_tar_gz = $attrib_ref->{shared_util_of}{dest}->path(
$m_ctx, 'sys-cache', $ctx->get_id() . '.tar.gz',
);
if (-f $cache_tar_gz) {
my @command = (
qw{tar -x -z}, '-C', dirname($cache_tar_gz), '-f', $cache_tar_gz,
);
my %value_of = %{$UTIL->shell_simple(\@command)};
if ($value_of{'rc'} == 0) {
unlink($cache_tar_gz);
}
}
# Start the parallel task runner to do project tree caches update
my $timer = $UTIL->timer();
my $n_jobs = $m_ctx->get_option_of('jobs');
my $n_trees = scalar(
grep {!$_->get_cache()}
map {@{$_->get_trees()}}
values(%{$ctx->get_project_of()})
);
if ($n_trees == 0) {
return;
}
if ($n_jobs && $n_jobs > $n_trees) {
$n_jobs = $n_trees;
}
my $elapse_tasks = 0;
my @args = ($attrib_ref, $m_ctx, $ctx);
my $runner = $UTIL->task_runner(
sub {_project_tree_cache_update_by_export(@args, @_)},
$n_jobs,
);
my $n = eval {
$runner->main(
_project_tree_cache_update_get_func(@args),
_project_tree_cache_update_put_func(@args, \$elapse_tasks),
);
};
my $e = $@;
$runner->destroy();
if ($e) {
_finally($attrib_ref, $m_ctx, $ctx);
die($e);
}
$UTIL->event(
FCM::Context::Event->MAKE_EXTRACT_RUNNER_SUMMARY,
'tree-cache-export', $n, $timer->(), $elapse_tasks,
);
}
# Updates the source cache for a project tree by exporting it.
sub _project_tree_cache_update_by_export {
my ($attrib_ref, $m_ctx, $ctx, $tree) = @_;
my $cache = $tree->get_cache();
# Exports the smallest common tree
my $root_ns;
SOURCE:
for my $source (@{$tree->get_sources()}) {
if ($source->is_unchanged()) {
next SOURCE;
}
if (!defined($root_ns)) {
$root_ns = $source->get_ns_in_tree();
next SOURCE;
}
$root_ns = $UTIL->ns_common(
$root_ns, $source->get_ns_in_tree(),
);
if (!$root_ns) {
last SOURCE;
}
}
if (!defined($root_ns)) {
return;
}
my $cache_ns = $root_ns ? catfile($cache, $root_ns) : $cache;
my $locator_ns = $UTIL->loc_cat(
$tree->get_locator(), split($UTIL->ns_sep(), $root_ns),
);
eval{
mkpath(dirname($cache_ns));
$UTIL->loc_export($locator_ns, $cache_ns);
};
if (my $e = $@ || !-e $cache_ns && !-l $cache_ns) {
return $E->throw($E->DEST_CREATE, $cache_ns, $e);
}
}
# Generates an iterator for each tree requiring cache update.
sub _project_tree_cache_update_get_func {
my ($attrib_ref, $m_ctx, $ctx) = @_;
my @trees = map {@{$_->get_trees()}} values(%{$ctx->get_project_of()});
sub {
while (my $tree = shift(@trees)) {
if (!$tree->get_cache()) {
if ($UTIL->loc_export_ok($tree->get_locator())) {
my $cache = $attrib_ref->{shared_util_of}{dest}->path(
$m_ctx,
'sys-cache',
$ctx->get_id(),
$tree->get_ns(),
$tree->get_key(),
);
$tree->set_cache($cache);
rmtree($cache);
mkpath(dirname($cache));
my $id = $tree->get_ns() . '/' . $tree->get_key();
return FCM::Context::Task->new({ctx => $tree, id => $id});
}
else {
$tree->set_cache($tree->get_locator()->get_value());
_project_tree_cache_update_sources(
$attrib_ref, $m_ctx, $ctx, $tree,
);
}
}
}
return;
};
}
# Generates a callback when a tree has a cache.
sub _project_tree_cache_update_put_func {
my ($attrib_ref, $m_ctx, $ctx, $elapse_tasks_ref) = @_;
sub {
my ($task) = @_;
if ($task->get_state() eq $task->ST_FAILED) {
die($task->get_error());
}
my $ns = $task->get_ctx()->get_ns();
my $key = $task->get_ctx()->get_key();
my $tree = $ctx->get_project_of()->{$ns}->get_trees()->[$key];
_project_tree_cache_update_sources($attrib_ref, $m_ctx, $ctx, $tree);
${$elapse_tasks_ref} += $task->get_elapse();
};
}
# Sets the caches of individual project tree sources.
sub _project_tree_cache_update_sources {
my ($attrib_ref, $m_ctx, $ctx, $tree) = @_;
for my $source (@{$tree->get_sources()}) {
my $cache = catfile(
$tree->get_cache(),
split($UTIL->ns_sep(), $source->get_ns_in_tree()),
);
$source->set_cache($cache);
}
}
# Handles symbolic links.
sub _symlink_handle {
my ($attrib_ref, $m_ctx, $ctx) = @_;
TARGET:
while (my ($ns, $target) = each(%{$ctx->get_target_of()})) {
if ($target->is_unchanged()) {
next TARGET;
}
my $source_hash_ref = $target->get_source_of();
# Remove sources that are symbolic links
while (my ($key, $source) = each(%{$source_hash_ref})) {
if ($source->get_cache() && -l $source->get_cache()) {
delete($source_hash_ref->{$key});
$UTIL->event(
FCM::Context::Event->MAKE_EXTRACT_SYMLINK, $source,
);
}
}
# It is OK to have a target with no sources, but a target must have a
# base source if it has at least one diff source.
if ( keys(%{$source_hash_ref})
&& !exists($source_hash_ref->{0})
) {
$source_hash_ref->{0} = $ctx->CTX_SOURCE->new(
{key_of_tree => 0, status => $ctx->CTX_SOURCE->ST_MISSING},
);
}
}
}
# Updates the targets.
sub _targets_update {
my ($attrib_ref, $m_ctx, $ctx) = @_;
my %basket_of = (status => {}, status_of_source => {});
eval {
while (my ($ns, $target) = each(%{$ctx->get_target_of()})) {
if ($target->get_status() eq $target->ST_UNKNOWN) {
my %source_of = %{$target->get_source_of()};
my $handler
= keys(%source_of) ? \&_target_update
: \&_target_delete
;
$handler->($attrib_ref, $m_ctx, $ctx, $target);
my $base = delete($source_of{0});
my @diffs = grep {!$_->is_unchanged()} values(%source_of);
$target->set_status_of_source(
!keys(%{$target->get_source_of()}) ? $target->ST_UNKNOWN
: $base->is_missing() ? $target->ST_ADDED
: (grep {$_->is_missing()} @diffs) ? $target->ST_DELETED
: scalar(@diffs) > 1 ? $target->ST_MERGED
: scalar(@diffs) ? $target->ST_MODIFIED
: $target->ST_UNCHANGED
);
$UTIL->event(
FCM::Context::Event->MAKE_EXTRACT_TARGET, $target,
);
}
$basket_of{status}{$target->get_status()}++;
$basket_of{status_of_source}{$target->get_status_of_source()}++;
}
};
if (my $e = $@) {
_finally($attrib_ref, $m_ctx, $ctx);
die($e);
}
$UTIL->event(
FCM::Context::Event->MAKE_EXTRACT_TARGET_SUMMARY, \%basket_of,
);
_finally($attrib_ref, $m_ctx, $ctx);
}
# Updates a deleted target.
sub _target_delete {
my ($attrib_ref, $m_ctx, $ctx, $target) = @_;
my ($dest, @inherited_dests) = @{$target->get_dests()};
if (-f $dest) {
unlink($dest) || return $E->throw($E->DEST_CLEAN, $dest, $!);
$target->set_status($target->ST_DELETED);
}
for my $inherited_dest (@inherited_dests) {
if (-f $inherited_dest) {
$target->set_status($target->ST_O_DELETED);
return;
}
}
}
# Updates a normal target.
sub _target_update {
my ($attrib_ref, $m_ctx, $ctx, $target) = @_;
my %source_of = %{$target->get_source_of()};
my $source_of_base = delete($source_of{0});
# Either missing source in a diff-tree
# Or missing source in base-tree and no diff-trees
if ( (grep {$_->is_missing()} values(%source_of))
|| $source_of_base->is_missing() && !keys(%source_of)
) {
return _target_delete($attrib_ref, $m_ctx, $ctx, $target);
}
my $path = _target_update_source($attrib_ref, $m_ctx, $ctx, $target);
# Note: $path may be a File::Temp object.
my ($is_diff, $is_diff_in_perms, $is_in_prev, $rc) = (1, 1, undef, 1);
DEST:
for my $i (0 .. @{$target->get_dests()} - 1) {
my $dest = $target->get_dests()->[$i];
if (-f $dest) {
$is_in_prev = $i;
($is_diff_in_perms, $is_diff) = _compare("$path", $dest);
last DEST;
}
}
if (!$is_diff && !$is_diff_in_perms) {
$target->set_path($target->get_dests()->[$is_in_prev]);
$target->set_status($target->ST_UNCHANGED);
return; # up to date
}
my $dest = $target->get_dests()->[0];
if ($is_diff) {
my $dest_dir = dirname($dest);
if (!-d $dest_dir) {
eval {mkpath($dest_dir)};
if (my $e = $@) {
return $E->throw($E->DEST_CREATE, $dest_dir, $e);
}
}
copy("$path", $dest)
|| return $E->throw($E->COPY, ["$path", $dest], $!);
}
chmod((stat("$path"))[2] & oct(7777), $dest)
|| return $E->throw($E->DEST_CREATE, $dest, $!);
$target->set_path($target->get_dests()->[0]);
$target->set_status(
$is_in_prev ? $target->ST_O_ADDED
: defined($is_in_prev) ? $target->ST_MODIFIED
: $target->ST_ADDED
);
}
# Returns the source path that is to be used to update a target.
sub _target_update_source {
my ($attrib_ref, $m_ctx, $ctx, $target) = @_;
my %source_of = %{$target->get_source_of()};
my $path_of_base = delete($source_of{0})->get_cache();
my @keys_and_paths;
while (my ($key, $source) = each(%source_of)) {
my $path = $source->get_cache();
if (!$path_of_base || _compare($path_of_base, $path)) {
if (!grep {!_compare($_->[1], $path)} @keys_and_paths) {
push(@keys_and_paths, [$key, $path]);
}
}
else {
$source->set_status($source->ST_UNCHANGED);
}
}
my @args = (
$m_ctx, $ctx, $target, $path_of_base,
(sort {$a->[0] <=> $b->[0]} @keys_and_paths),
);
return (
@keys_and_paths == 0 ? $path_of_base
: @keys_and_paths == 1 ? $keys_and_paths[0][1]
: _target_update_source_merge($attrib_ref, @args)
);
}
# Merges changes in contents of paths in @keys_and_paths against content in
# $path_of_base.
sub _target_update_source_merge {
my ($attrib_ref, $m_ctx, $ctx, $target, $path_of_base, @keys_and_paths) = @_;
if (!$path_of_base) {
$path_of_base = File::Temp->new();
if (!defined($path_of_base) || !close($path_of_base)) {
return $E->throw($E->DEST_CREATE, tmpdir(), $!);
}
}
my ($key_of_mine, $path_of_mine) = @{shift(@keys_and_paths)};
my @keys_done = ($key_of_mine);
while (my $key_and_path = shift(@keys_and_paths)) {
my ($key, $path) = @{$key_and_path};
my @command = (
(map {_props($attrib_ref, $_, $ctx)} qw{diff3 diff3.flags}),
"$path_of_mine", "$path_of_base", $path,
);
my %value_of = %{$UTIL->shell_simple(\@command)};
if ($value_of{rc} && $value_of{rc} == 1) {
# Write conflict output to .fcm-make/extract/conflict/$NS
my $file = $attrib_ref->{shared_util_of}{dest}->path(
$m_ctx, 'sys', $ctx->get_id(), 'merge',
$target->get_ns() . '.diff',
);
$UTIL->file_save($file, $value_of{o});
return $E->throw($E->EXTRACT_MERGE, {
'target' => $target,
'output' => $file,
'keys_done' => \@keys_done,
'key' => $key,
'keys_left' => [map {$_->[0]} @keys_and_paths],
});
}
elsif ($value_of{rc}) {
return $E->throw(
$E->SHELL, {command_list => \@command, %value_of}, $value_of{e},
);
}
my $perm = (stat("$path_of_mine"))[2] & 07777 | (stat($path))[2] & 07777;
for my $action (
sub {$path_of_mine = File::Temp->new()},
sub {print({$path_of_mine} $value_of{o})},
sub {close($path_of_mine)},
sub {chmod($perm, "$path_of_mine")},
) {
$action->() || return $E->throw($E->DEST_CREATE, "$path_of_mine", $!);
}
push(@keys_done, $key);
}
return $path_of_mine;
}
# Perform final actions.
# Archive cache directory if necessary.
sub _finally {
my ($attrib_ref, $m_ctx, $ctx) = @_;
if (!$m_ctx->get_option_of('archive')) {
return;
}
my $cache = $attrib_ref->{shared_util_of}{dest}->path(
$m_ctx, 'sys-cache', $ctx->get_id(),
);
if (-d $cache) {
my @command = (
qw{tar -c -z}, '-C', dirname($cache), '-f', $cache . '.tar.gz',
$ctx->get_id(),
);
my %value_of = %{$UTIL->shell_simple(\@command)};
if ($value_of{'rc'} == 0) {
rmtree($cache);
}
}
}
# In scalar context, returns true if the contents or permissions of 2 paths
# differ. In array context, returns ($is_diff_in_perms, $is_diff_in_content).
sub _compare {
my ($path1, $path2) = @_;
my $is_diff_in_perms = (stat($path1))[2] != (stat($path2))[2];
wantarray()
? ($is_diff_in_perms, compare($path1, $path2))
: ($is_diff_in_perms || compare($path1, $path2))
;
}
# Returns true if two sources are the same or if their latest modified revisions
# are the same.
sub _source_eq {
my ($source1, $source2) = @_;
my ($locator1, $locator2) = map {$_->get_locator()} ($source1, $source2);
# Compares their value + mtime or their last modified revision
$locator1->get_value() eq $locator2->get_value()
&& defined($locator1->get_last_mod_time())
&& defined($locator2->get_last_mod_time())
&& $locator1->get_last_mod_time() eq $locator2->get_last_mod_time()
|| defined($locator1->get_last_mod_rev())
&& defined($locator2->get_last_mod_rev())
&& $locator1->get_last_mod_rev() eq $locator2->get_last_mod_rev()
;
}
# ------------------------------------------------------------------------------
1;
__END__
=head1 NAME
FCM::System::Make::Extract
=head1 SYNOPSIS
use FCM::System::Make::Extract;
my $extract = FCM::System::Make::Extract->new(\%attrib);
$extract->($m_ctx, $ctx);
=head1 DESCRIPTION
Implements the extract sub-system. An instance of this class is expected to be
initialised and called by L.
=head1 METHODS
See L for detail.
=head1 ATTRIBUTES
The $class->new(\%attrib) method of this class supports the following
attributes:
=over 4
=item config_parser_of
A HASH to map the labels in a configuration file to their parsers. (default =
%FCM::System::Make::Extract::CONFIG_PARSER_OF)
=item prop_of
A HASH to map the names of the properties to their settings. Each setting
is a 2-element ARRAY reference, where element [0] is the default setting
and element [1] is a flag to indicate whether the property accepts a name-space
or not. (default = %FCM::System::Make::Extract::PROP_OF)
=item shared_util_of
See L for detail.
=item util
See L for detail.
=back
=head1 TODO
Handle alternate method of merge (e.g. Algorithm::Merge).
=head1 COPYRIGHT
Copyright (C) 2006-2021 British Crown (Met Office) & Contributors.
=cut