New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
Extract.pm in vendors/lib/FCM/System/Make – NEMO

source: vendors/lib/FCM/System/Make/Extract.pm @ 10669

Last change on this file since 10669 was 10669, checked in by nicolasmartin, 5 years ago

Import latest FCM release from Github into the repository for testing
File size: 46.5 KB
Line 
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# ------------------------------------------------------------------------------
19use strict;
20use warnings;
21
22# ------------------------------------------------------------------------------
23package FCM::System::Make::Extract;
24use base qw{FCM::Class::CODE};
25
26use FCM::Context::ConfigEntry;
27use FCM::Context::Event;
28use FCM::Context::Make::Extract;
29use FCM::Context::Locator;
30use FCM::Context::Task;
31use FCM::System::Exception;
32use FCM::System::Make::Share::Subsystem;
33use File::Basename qw{dirname};
34use File::Compare qw{compare};
35use File::Copy qw{copy};
36use File::Path qw{mkpath rmtree};
37use File::Spec::Functions qw{abs2rel catfile tmpdir};
38use File::Temp;
39use List::Util qw{first};
40use Storable qw{dclone};
41
42# Aliases
43our $UTIL;
44my $E = 'FCM::System::Exception';
45
46# Configuration parser map: label to action
47our %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
62our @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.
86sub _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.
95sub _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.
115sub _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.
166sub _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.
202sub _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.
235sub _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-*.
241sub _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.
280sub _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.
295sub _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.
391sub _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.
397sub _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.
447sub _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.
463sub _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.
650sub _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.
699sub _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.
775sub _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.
832sub _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.
886sub _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.
924sub _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.
957sub _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.
973sub _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.
985sub _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.
1015sub _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.
1056sub _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.
1072sub _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.
1123sub _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.
1152sub _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.
1205sub _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).
1227sub _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.
1238sub _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# ------------------------------------------------------------------------------
12531;
1254__END__
1255
1256=head1 NAME
1257
1258FCM::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
1268Implements the extract sub-system. An instance of this class is expected to be
1269initialised and called by L<FCM::System::Make|FCM::System::Make>.
1270
1271=head1 METHODS
1272
1273See L<FCM::System::Make|FCM::System::Make> for detail.
1274
1275=head1 ATTRIBUTES
1276
1277The $class->new(\%attrib) method of this class supports the following
1278attributes:
1279
1280=over 4
1281
1282=item config_parser_of
1283
1284A 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
1289A HASH to map the names of the properties to their settings. Each setting
1290is a 2-element ARRAY reference, where element [0] is the default setting
1291and element [1] is a flag to indicate whether the property accepts a name-space
1292or not. (default = %FCM::System::Make::Extract::PROP_OF)
1293
1294=item shared_util_of
1295
1296See L<FCM::System::Make|FCM::System::Make> for detail.
1297
1298=item util
1299
1300See L<FCM::System::Make|FCM::System::Make> for detail.
1301
1302=back
1303
1304=head1 TODO
1305
1306Handle alternate method of merge (e.g. Algorithm::Merge).
1307
1308=head1 COPYRIGHT
1309
1310(C) Crown copyright Met Office. All rights reserved.
1311
1312=cut
Note: See TracBrowser for help on using the repository browser.