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.
Build.pm in vendors/lib/FCM/System/Make – NEMO

source: vendors/lib/FCM/System/Make/Build.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: 63.7 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# ------------------------------------------------------------------------------
22package FCM::System::Make::Build;
23use base qw{FCM::Class::CODE};
24
25use Cwd qw{cwd realpath};
26use FCM::Context::ConfigEntry;
27use FCM::Context::Event;
28use FCM::Context::Make::Build;
29use FCM::Context::Task;
30use FCM::System::Exception;
31use FCM::System::Make::Build::FileType::C;
32use FCM::System::Make::Build::FileType::CXX;
33use FCM::System::Make::Build::FileType::Data;
34use FCM::System::Make::Build::FileType::Fortran;
35use FCM::System::Make::Build::FileType::H;
36use FCM::System::Make::Build::FileType::NS;
37use FCM::System::Make::Build::FileType::Script;
38use FCM::System::Make::Share::Subsystem;
39use File::Basename qw{basename dirname fileparse};
40use File::Find qw{find};
41use File::Path qw{mkpath rmtree};
42use File::Spec::Functions qw{abs2rel catfile rel2abs splitdir splitpath};
43use Storable qw{dclone};
44use Text::ParseWords qw{shellwords};
45
46# Aliases
47our ($EVENT, $UTIL);
48my $E = 'FCM::System::Exception';
49my $STATE = 'FCM::System::Make::Build::State';
50
51# Classes for working with typed source files
52our @FILE_TYPE_UTILS = (
53    'FCM::System::Make::Build::FileType::C',
54    'FCM::System::Make::Build::FileType::CXX',
55    'FCM::System::Make::Build::FileType::Data',
56    'FCM::System::Make::Build::FileType::Fortran',
57    'FCM::System::Make::Build::FileType::H',
58    'FCM::System::Make::Build::FileType::NS',
59    'FCM::System::Make::Build::FileType::Script',
60);
61
62# Default target selection
63our %TARGET_SELECT_BY = (
64    'category' => {},
65    'key'      => {},
66    'task'     => {},
67);
68
69# Configuration parser label to action map
70our %CONFIG_PARSER_OF = (
71    'ns-excl' => _config_parse_ns_filter_func(sub {$_[0]->get_input_ns_excl()}),
72    'ns-incl' => _config_parse_ns_filter_func(sub {$_[0]->get_input_ns_incl()}),
73    'source'  => \&_config_parse_source,
74    'target'  => \&_config_parse_target,
75    'target-rename' => \&_config_parse_target_rename,
76);
77
78# Default properties
79our %PROP_OF = (
80    #                               [default       , ns-ok]
81    'archive-ok-target-category' => [q{include o}  , undef],
82    'checksum-method'            => [q{}           , undef],
83    'ignore-missing-dep-ns'      => [q{}           , undef],
84    'no-step-source'             => [q{}           , undef],
85    'no-inherit-source'          => [q{}           , undef],
86    'no-inherit-target-category' => [q{bin etc lib}, undef],
87);
88
89# Creates the class.
90__PACKAGE__->class(
91    {   config_parser_of  => {isa => '%', default => {%CONFIG_PARSER_OF}},
92        file_type_utils   => {isa => '@', default => [@FILE_TYPE_UTILS]},
93        file_type_util_of => '%',
94        prop_of           => {isa => '%', default => {%PROP_OF}},
95        target_select_by  => {isa => '%', default => {%TARGET_SELECT_BY}},
96        util              => '&',
97    },
98    {   init => \&_init,
99        action_of => {
100            config_parse              => \&_config_parse,
101            config_parse_class_prop   => \&_config_parse_class_prop,
102            config_parse_inherit_hook => \&_config_parse_inherit_hook,
103            config_unparse            => \&_config_unparse,
104            config_unparse_class_prop => \&_config_unparse_class_prop,
105            ctx                       => \&_ctx,
106            ctx_load_hook             => \&_ctx_load_hook,
107            main                      => \&_main,
108        },
109    },
110);
111
112# Initialises the helpers of the class.
113sub _init {
114    my ($attrib_ref) = @_;
115    # Initialises file type utilities, if necessary
116    for my $class (@{$attrib_ref->{file_type_utils}}) {
117        $attrib_ref->{util}->class_load($class);
118        my $file_type_util = $class->new({util => $attrib_ref->{util}});
119        my $id = $file_type_util->id();
120        if (!defined($attrib_ref->{file_type_util_of}{$id})) {
121            $attrib_ref->{file_type_util_of}{$id} = $file_type_util;
122        }
123    }
124    # Initialises properties derived from the file type utilities
125    # TBD: warn if a property is already set and is different from previous?
126    while (
127        my ($id, $file_type_util) = each(%{$attrib_ref->{file_type_util_of}})
128    ) {
129        # File name extension, name pattern and she-bang pattern
130        for my $key (qw{ext pat she}) {
131            my $method = 'file_' . $key;
132            if ($file_type_util->can($method)) {
133                my $value = $file_type_util->$method();
134                if (defined($value)) {
135                    $attrib_ref->{prop_of}{"file-$key.$id"} = [$value];
136                }
137            }
138        }
139        # Dependency types
140        if ($file_type_util->can('source_analyse_deps')) {
141            for my $name ($file_type_util->source_analyse_deps()) {
142                $attrib_ref->{prop_of}{"dep.$name"} = [q{}, 1];
143                $attrib_ref->{prop_of}{"no-dep.$name"} = [q{}, 1];
144            }
145        }
146        # Name-space dependency types
147        if ($file_type_util->can('ns_targets_deps')) {
148            for my $name ($file_type_util->ns_targets_deps()) {
149                $attrib_ref->{prop_of}{"ns-dep.$name"} = [q{}, 1];
150            }
151        }
152        # Target extensions
153        if ($file_type_util->can('target_file_ext_of')) {
154            while (my ($key, $value)
155                = each(%{$file_type_util->target_file_ext_of()})
156            ) {
157                $attrib_ref->{prop_of}{"file-ext.$key"} = [$value, 1];
158            }
159        }
160        # Target file naming options
161        if ($file_type_util->can('target_file_name_option_of')) {
162            while (my ($key, $value)
163                = each(%{$file_type_util->target_file_name_option_of()})
164            ) {
165                $attrib_ref->{prop_of}{"file-name-option.$key"} = [$value, 1];
166            }
167        }
168        # Task properties
169        my %task_of = %{$file_type_util->task_of()};
170        while (my ($name, $task) = each(%task_of)) {
171            if ($task->can('prop_of')) {
172                my %prop_of = %{$task->prop_of()};
173                while (my ($key, $value) = each(%prop_of)) {
174                    $attrib_ref->{prop_of}{$key} = [$value, 1];
175                }
176            }
177        }
178    }
179}
180
181# A hook command for the "inherit/use" declaration.
182sub _config_parse_inherit_hook {
183    my ($attrib_ref, $ctx, $i_ctx) = @_;
184    push(@{$ctx->get_input_ns_excl()}, @{$i_ctx->get_input_ns_excl()});
185    push(@{$ctx->get_input_ns_incl()}, @{$i_ctx->get_input_ns_incl()});
186    while (my ($key, $value) = each(%{$i_ctx->get_target_key_of()})) {
187        $ctx->get_target_key_of()->{$key} = $value;
188    }
189    while (my ($key, $item_ref) = each(%{$i_ctx->get_target_select_by()})) {
190        while (my ($key2, $attr_set) = each(%{$item_ref})) {
191            if (ref($attr_set)) {
192                $ctx->get_target_select_by()->{$key}{$key2} = {%{$attr_set}};
193            }
194            else {
195                # Backward compat, $key2 is an $attr
196                $ctx->get_target_select_by()->{$key}{q{}}{$key2} = 1;
197            }
198        }
199    }
200    _config_parse_inherit_hook_prop($attrib_ref, $ctx, $i_ctx);
201}
202
203# Returns a function to parse a build/preprocess.ns-??cl declaration.
204sub _config_parse_ns_filter_func {
205    my ($getter) = @_;
206    sub {
207        my ($attrib_ref, $ctx, $entry) = @_;
208        if (@{$entry->get_ns_list()}) {
209            return $E->throw($E->CONFIG_NS, $entry);
210        }
211        @{$getter->($ctx)} = map {$_ eq q{/} ? q{} : $_} $entry->get_values();
212    };
213}
214
215# Parses a build/preprocess.source declaration.
216sub _config_parse_source {
217    my ($attrib_ref, $ctx, $entry) = @_;
218    my ($ns) = @{$entry->get_ns_list()};
219    $ns ||= q{};
220    $ctx->get_input_source_of()->{$ns} = [$entry->get_values()];
221}
222
223# Parses a build/preprocess.target declaration.
224sub _config_parse_target {
225    my ($attrib_ref, $ctx, $entry) = @_;
226    my %modifier_of = %{$entry->get_modifier_of()};
227    if (!(%modifier_of)) {
228        %modifier_of = (key => 1);
229    }
230    my @ns_list = map {$_ eq q{/} ? q{} : $_} @{$entry->get_ns_list()};
231    if (exists($modifier_of{'key'}) && grep {$_} @ns_list) {
232        return $E->throw($E->CONFIG_NS, $entry);
233    }
234    if (!@ns_list) {
235        @ns_list = (q{});
236    }
237    while (my $name = each(%modifier_of)) {
238        if (!grep {$_ eq $name} qw{category key task}) {
239            return $E->throw($E->CONFIG_MODIFIER, $entry);
240        }
241        my %attr_set = map {($_ => 1)} $entry->get_values();
242        for my $ns (@ns_list) {
243            $ctx->get_target_select_by()->{$name}{$ns} = \%attr_set;
244        }
245    }
246}
247
248# Parses a build/preprocess.target-rename declaration.
249sub _config_parse_target_rename {
250    my ($attrib_ref, $ctx, $entry) = @_;
251    $ctx->set_target_key_of({
252        map {
253            my ($old, $new) = split(qr{:}msx, $_, 2);
254            if (!$old || !$new) {
255                return $E->throw($E->CONFIG_VALUE, $entry);
256            }
257            ($old => $new);
258        } ($entry->get_values()),
259    });
260}
261
262# Turns a context into a list of configuration entries.
263sub _config_unparse {
264    my ($attrib_ref, $ctx) = @_;
265    my %LABEL_OF
266        = map {($_ => $ctx->get_id() . q{.} . $_)} keys(%CONFIG_PARSER_OF);
267    (   (   @{$ctx->get_input_ns_excl()}
268            ? FCM::Context::ConfigEntry->new({
269                label => $LABEL_OF{'ns-excl'},
270                value => _config_unparse_join(
271                    map {$_ ? $_ : q{/}} @{$ctx->get_input_ns_excl()}
272                ),
273            })
274            : ()
275        ),
276        (   @{$ctx->get_input_ns_incl()}
277            ? FCM::Context::ConfigEntry->new({
278                label => $LABEL_OF{'ns-incl'},
279                value => _config_unparse_join(
280                    map {$_ ? $_ : q{/}} @{$ctx->get_input_ns_incl()}
281                ),
282            })
283            : ()
284        ),
285        (   map {
286                FCM::Context::ConfigEntry->new({
287                    label   => $LABEL_OF{source},
288                    ns_list => [$_],
289                    value   => _config_unparse_join(
290                        sort(@{$ctx->get_input_source_of()->{$_}})
291                    ),
292                })
293            }
294            sort keys(%{$ctx->get_input_source_of()})
295        ),
296        (   keys(%{$ctx->get_target_key_of()})
297            ? FCM::Context::ConfigEntry->new({
298                label => $LABEL_OF{'target-rename'},
299                value => _config_unparse_join(
300                    map {$_ . ':' . $ctx->get_target_key_of()->{$_}}
301                    sort keys(%{$ctx->get_target_key_of()})
302                ),
303            })
304            : ()
305        ),
306        (   map {
307                my $modifier = $_;
308                map {
309                    my $ns = $_;
310                    my @values = sort(keys(
311                        %{$ctx->get_target_select_by()->{$modifier}{$ns}}
312                    ));
313                    FCM::Context::ConfigEntry->new({
314                        label       => $LABEL_OF{'target'},
315                        modifier_of => {$modifier => 1},
316                        ns_list     => [$ns],
317                        value       => _config_unparse_join(@values),
318                    });
319                }
320                sort keys(%{$ctx->get_target_select_by()->{$modifier}});
321            }
322            sort keys(%{$ctx->get_target_select_by()})
323        ),
324        _config_unparse_prop($attrib_ref, $ctx),
325    );
326}
327
328# Returns a new context.
329sub _ctx {
330    my ($attrib_ref, $id_of_class, $id) = @_;
331    FCM::Context::Make::Build->new({
332        id               => $id,
333        id_of_class      => $id_of_class,
334        target_select_by => dclone($attrib_ref->{target_select_by}),
335    });
336}
337
338# Hook when loading a previous ctx.
339sub _ctx_load_hook {
340    my ($attrib_ref, $old_m_ctx, $old_ctx, $old_m_dest, $old_dest) = @_;
341    my $path_mod_func = sub {
342        my ($get_func, $set_func) = @_;
343        my $path = $get_func->();
344        if (!defined($path)) {
345            return;
346        }
347        my $rel_path = abs2rel($path, $old_m_dest);
348        if (index($rel_path, '..') != 0) {
349            $set_func->(catfile($old_m_ctx->get_dest(), $rel_path));
350        }
351    };
352    if (@{$old_ctx->get_dests()}) {
353        $old_ctx->get_dests()->[0] = $old_ctx->get_dest();
354    }
355    while (my ($ns, $source) = each(%{$old_ctx->get_source_of()})) {
356        $path_mod_func->(
357            sub {$source->get_path()},
358            sub {$source->set_path(@_)},
359        );
360    }
361    while (my ($key, $target) = each(%{$old_ctx->get_target_of()})) {
362        $path_mod_func->(
363            sub {$target->get_path()},
364            sub {$target->set_path(@_)},
365        );
366        $path_mod_func->(
367            sub {$target->get_path_of_prev()},
368            sub {$target->set_path_of_prev(@_)},
369        );
370        $path_mod_func->(
371            sub {$target->get_path_of_source()},
372            sub {$target->set_path_of_source(@_)},
373        );
374    }
375}
376
377# The main function of the class.
378sub _main {
379    my ($attrib_ref, $m_ctx, $ctx) = @_;
380    local($UTIL) = $attrib_ref->{util};
381    local($EVENT) = sub {$UTIL->event(@_)};
382    for my $function (
383        \&_sources_locate,
384        \&_sources_type,
385        \&_sources_analyse,
386        \&_targets_update,
387    ) {
388        $function->($attrib_ref, $m_ctx, $ctx);
389    }
390}
391
392# Locates the actual source files, and determines their types.
393sub _sources_locate {
394    my ($attrib_ref, $m_ctx, $ctx) = @_;
395    # From inherited
396    my %NO_INHERIT_FROM
397        = map {($_ => 1)} _props($attrib_ref, 'no-inherit-source', $ctx);
398    if (!$NO_INHERIT_FROM{'*'}) {
399        for my $i_ctx (_i_ctx_list($m_ctx, $ctx)) {
400            while (my ($ns, $source) = each(%{$i_ctx->get_source_of()})) {
401                if (!exists($NO_INHERIT_FROM{$ns})) { # exact name-spaces only
402                    $ctx->get_source_of()->{$ns} = dclone($source);
403                }
404            }
405        }
406    }
407    # From specified input
408    while (my ($ns, $input_sources_ref) = each(%{$ctx->get_input_source_of()})) {
409        for my $input_source (@{$input_sources_ref}) {
410            my $path = realpath(rel2abs($input_source, $m_ctx->get_dest()));
411            _sources_locate_by_find($attrib_ref, $m_ctx, $ctx, $ns, $path);
412        }
413    }
414    # From completed make destinations
415    my %NO_SOURCE_FROM
416        = map {($_, 1)} _props($attrib_ref, 'no-step-source', $ctx);
417    for my $step (@{$m_ctx->get_steps()}) {
418        my $a_ctx = $m_ctx->get_ctx_of($step);
419        if (    !exists($NO_SOURCE_FROM{$step})
420            &&  defined($a_ctx)
421            &&  $a_ctx->get_status() eq $m_ctx->ST_OK
422            &&  $a_ctx->can('get_target_of')
423        ) {
424            my @target_list
425                = grep {$_->can_be_source()} values(%{$a_ctx->get_target_of()});
426            for my $target (@target_list) {
427                if ($target->is_ok() && -e $target->get_path()) {
428                    my $checksum;
429                    if ($target->can('get_checksum')) {
430                        $checksum = $target->get_checksum();
431                    }
432                    my $source = $ctx->CTX_SOURCE->new({
433                        checksum => $checksum,
434                        ns       => $target->get_ns(),
435                        path     => $target->get_path(),
436                    });
437                    $ctx->get_source_of()->{$target->get_ns()} = $source;
438                }
439                elsif (exists($ctx->get_source_of()->{$target->get_ns()})) {
440                    delete($ctx->get_source_of()->{$target->get_ns()});
441                }
442            }
443        }
444    }
445    # Applies filter
446    my %INPUT_NS_EXCL = map {($_, 1)} @{$ctx->get_input_ns_excl()};
447    my %INPUT_NS_INCL = map {($_, 1)} @{$ctx->get_input_ns_incl()};
448    if (keys(%INPUT_NS_EXCL) || keys(%INPUT_NS_INCL)) {
449        while (my ($ns, $source) = each(%{$ctx->get_source_of()})) {
450            my $ns_iter_ref = $UTIL->ns_iter($ns, $UTIL->NS_ITER_UP);
451            NS:
452            while (defined(my $head = $ns_iter_ref->())) {
453                if (exists($INPUT_NS_INCL{$head})) {
454                    last NS;
455                }
456                if (exists($INPUT_NS_EXCL{$head})) {
457                    delete($ctx->get_source_of()->{$ns});
458                    last NS;
459                }
460            }
461        }
462    }
463}
464
465# Locates the actual source files in $path.
466sub _sources_locate_by_find {
467    my ($attrib_ref, $m_ctx, $ctx, $key, $path) = @_;
468    if (!-e $path) {
469        return $E->throw($E->BUILD_SOURCE, $path, $!);
470    }
471    find(
472        sub {
473            my $path_found = $File::Find::name;
474            if (-d $path_found) {
475                return;
476            }
477            my $ns = abs2rel($path_found, $path);
478            if ($ns ne q{.}) {
479                for my $name (split(q{/}, $ns)) {
480                    if (index($name, q{.}) == 0) {
481                        return; # ignore Unix hidden/system files
482                    }
483                }
484            }
485            if ($key) {
486                $ns = $UTIL->ns_cat($key, $ns);
487            }
488            $ctx->get_source_of()->{$ns}
489                = $ctx->CTX_SOURCE->new({ns => $ns, path => $path_found});
490        },
491        $path,
492    );
493}
494
495# Determines source types.
496sub _sources_type {
497    my ($attrib_ref, $m_ctx, $ctx) = @_;
498    my %INPUT_FILE_EXT_TO_TYPE_MAP;
499    my %INPUT_FILE_PAT_TO_TYPE_MAP;
500    my %INPUT_FILE_SHE_TO_TYPE_MAP;
501    for (
502        ['file-ext.', \%INPUT_FILE_EXT_TO_TYPE_MAP, 1],
503        ['file-pat.', \%INPUT_FILE_PAT_TO_TYPE_MAP, 0],
504        ['file-she.', \%INPUT_FILE_SHE_TO_TYPE_MAP, 0],
505    ) {
506        my ($prefix, $map_ref, $value_is_words) = @{$_};
507        for my $id (keys(%{$attrib_ref->{file_type_util_of}})) {
508            my $name = $prefix . $id;
509            my $value = _prop($attrib_ref, $name, $ctx);
510            if (defined($value)) {
511                for my $key (($value_is_words ? shellwords($value) : ($value))) {
512                    $map_ref->{$key} = $id;
513                }
514            }
515        }
516    }
517    my $type_func = sub {
518        my ($path) = @_;
519        # Try file name extension
520        my $extension = $UTIL->file_ext($path);
521        $extension = $extension ? q{.} . $extension : undef;
522        if ($extension && exists($INPUT_FILE_EXT_TO_TYPE_MAP{$extension})) {
523            return $INPUT_FILE_EXT_TO_TYPE_MAP{$extension};
524        }
525        # Try she-bang line
526        if (-T $path) {
527            my $line = $UTIL->file_head($path);
528            if ($line) {
529                while (my ($pattern, $type) = each(%INPUT_FILE_SHE_TO_TYPE_MAP)) {
530                    if (index($line, '#!') == 0) { # OK to hard code this
531                        keys(%INPUT_FILE_SHE_TO_TYPE_MAP); # reset iterator
532                        return $type;
533                    }
534                }
535            }
536        }
537        # Try file name pattern
538        my $base_name = basename($path);
539        while (my ($pattern, $type) = each(%INPUT_FILE_PAT_TO_TYPE_MAP)) {
540            if ($base_name =~ $pattern) {
541                keys(%INPUT_FILE_PAT_TO_TYPE_MAP); # reset iterator
542                return $type;
543            }
544        }
545        return q{};
546    };
547    while (my ($ns, $source) = each(%{$ctx->get_source_of()})) {
548        if (!defined($source->get_type())) {
549            $source->set_type($type_func->($source->get_path()));
550        }
551    }
552}
553
554# Reads source files to gather dependency and other information.
555sub _sources_analyse {
556    my ($attrib_ref, $m_ctx, $ctx) = @_;
557    my $timer = $UTIL->timer();
558    my $checksum_method = _prop($attrib_ref, 'checksum-method', $ctx);
559    my %FILE_TYPE_UTIL_OF = %{$attrib_ref->{file_type_util_of}};
560    # Checksum
561    while (my ($ns, $source) = each(%{$ctx->get_source_of()})) {
562        if (    exists($FILE_TYPE_UTIL_OF{$source->get_type()})
563            &&  !defined($source->get_checksum())
564        ) {
565            $source->set_checksum(
566                $UTIL->file_checksum($source->get_path(), $checksum_method),
567            );
568        }
569    }
570    # Source information
571    my $n_jobs = $m_ctx->get_option_of('jobs');
572    my $runner = $UTIL->task_runner(
573        sub {_source_analyse($attrib_ref, @_)},
574        $n_jobs,
575    );
576    my $elapse_tasks = 0;
577    my $n = eval {
578        $runner->main(
579            _source_analyse_get_func($attrib_ref, $m_ctx, $ctx),
580            _source_analyse_put_func($attrib_ref, $m_ctx, $ctx, \$elapse_tasks),
581        );
582    };
583    my $e = $@;
584    $runner->destroy();
585    if ($e) {
586        die($e);
587    }
588    my $n_total = scalar(keys(%{$ctx->get_source_of()}));
589    $EVENT->(
590        FCM::Context::Event->MAKE_BUILD_SOURCE_SUMMARY,
591        $n_total, $n, $timer->(), $elapse_tasks,
592    );
593}
594
595# Reads a source to gather information.
596sub _source_analyse {
597    my ($attrib_ref, $source) = @_;
598    my $FILE_TYPE_UTIL
599        = $attrib_ref->{file_type_util_of}->{$source->get_type()};
600    if (!$FILE_TYPE_UTIL->can('source_analyse')) {
601        return;
602    }
603    $FILE_TYPE_UTIL->source_analyse($source);
604}
605
606# Generates an iterator for each source file requiring information gathering.
607sub _source_analyse_get_func {
608    my ($attrib_ref, $m_ctx, $ctx) = @_;
609    my $P_SOURCE_GETTER
610        = _prev_hash_item_getter($m_ctx, $ctx, sub {$_[0]->get_source_of()});
611    my %FILE_TYPE_UTIL_OF = %{$attrib_ref->{file_type_util_of}};
612    my $exhausted;
613    sub {
614        if ($exhausted) {
615            return;
616        }
617        SOURCE:
618        while (my ($ns, $source) = each(%{$ctx->get_source_of()})) {
619            my $type = $source->get_type();
620            if (!exists($FILE_TYPE_UTIL_OF{$type})) {
621                next SOURCE;
622            }
623            # Stores the current properties relevant to the source
624            for my $dep_type ($FILE_TYPE_UTIL_OF{$type}->source_analyse_deps()) {
625                for my $n (map {$_ . q{.} . $dep_type} qw{dep no-dep}) {
626                    $source->get_prop_of()->{$n}
627                        = _prop($attrib_ref, $n, $ctx, $ns);
628                }
629            }
630            # Compare with previous source, if possible
631            my $p_source = $P_SOURCE_GETTER->($ns);
632            if (defined($p_source)) {
633                $source->set_up_to_date(
634                    $p_source->get_checksum() eq $source->get_checksum());
635                if (    $source->get_up_to_date()
636                    &&  !$UTIL->hash_cmp(
637                            map {$_->get_prop_of()} ($source, $p_source)
638                        )
639                ) {
640                    $source->set_info_of(dclone($p_source->get_info_of()));
641                    $source->set_deps(   dclone($p_source->get_deps()   ));
642                    next SOURCE;
643                }
644            }
645            return FCM::Context::Task->new({ctx => $source, id  => $ns});
646        }
647        $exhausted = 1;
648        return;
649    };
650}
651
652# Generates a callback when a source read completes.
653sub _source_analyse_put_func {
654    my ($attrib_ref, $m_ctx, $ctx, $elapse_tasks_ref) = @_;
655    my %FILE_TYPE_UTIL_OF = %{$attrib_ref->{file_type_util_of}};
656    sub {
657        my ($task) = @_;
658        if ($task->get_state() eq $task->ST_FAILED) {
659            die($task->get_error());
660        }
661        my $ns = $task->get_id();
662        my $source = $ctx->get_source_of()->{$ns} = $task->get_ctx();
663        for my $type (
664            $FILE_TYPE_UTIL_OF{$source->get_type()}->source_analyse_deps()
665        ) {
666            # Note: "dep" property: use name-space value only
667            my $key = 'dep.' . $type;
668            push(
669                @{$source->get_deps()},
670                (map {[$_, $type]} _props($attrib_ref, $key, $ctx, $ns)),
671            );
672        }
673        ${$elapse_tasks_ref} += $task->get_elapse();
674        $EVENT->(
675            FCM::Context::Event->MAKE_BUILD_SOURCE_ANALYSE,
676            $source, $task->get_elapse(),
677        );
678    }
679}
680
681# Updates the targets.
682sub _targets_update {
683    my ($attrib_ref, $m_ctx, $ctx) = @_;
684    my $timer = $UTIL->timer();
685    # Creates and changes directory to the destination
686    eval {mkpath($ctx->get_dest())};
687    if ($@) {
688        return $E->throw($E->DEST_CREATE, $ctx->get_dest());
689    }
690    my $old_cwd = cwd();
691    chdir($ctx->get_dest()) || die(sprintf("%s: %s\n", $ctx->get_dest(), $!));
692    # Extract any target category directories that are in .tar.gz
693    opendir(my $handle, '.');
694    while (my $name = readdir($handle)) {
695        if ((fileparse($name, '.tar.gz'))[2] eq '.tar.gz') {
696            my %value_of = %{$UTIL->shell_simple([qw{tar -x -z}, '-f', $name])};
697            if ($value_of{'rc'} == 0) {
698                unlink($name);
699            }
700        }
701    }
702    closedir($handle);
703    # Determines the destination search path
704    my $id = $ctx->get_id();
705    @{$ctx->get_dests()} = (
706        $ctx->get_dest(),
707        map {$_->get_ctx_of($id) ? @{$_->get_ctx_of($id)->get_dests()} : ()}
708            @{$m_ctx->get_inherit_ctx_list()}
709        ,
710    );
711    # Performs targets update
712    my $checksum_method = _prop($attrib_ref, 'checksum-method', $ctx);
713    my %stat_of = ();
714    eval {
715        my $n_jobs = $m_ctx->get_option_of('jobs');
716        my $runner = $UTIL->task_runner(
717            sub {_target_update($attrib_ref, $checksum_method, @_)},
718            $n_jobs,
719        );
720        eval {
721            my ($get_ref, $put_ref) = _targets_manager_funcs(
722                 $attrib_ref, $m_ctx, $ctx, \%stat_of,
723            );
724            $runner->main($get_ref, $put_ref);
725        };
726        my $e = $@;
727        $runner->destroy();
728        if ($e) {
729            die($e);
730        }
731    };
732    my $e = $@;
733    # Back to original working directory
734    chdir($old_cwd) || die(sprintf("%s: %s\n", $old_cwd, $!));
735    if ($e) {
736        _finally($attrib_ref, $m_ctx, $ctx);
737        die($e);
738    }
739    # Finally
740    my @targets = values(%{$ctx->get_target_of()});
741    for my $key (sort(keys(%stat_of))) {
742        $stat_of{$key}{n}{$ctx->CTX_TARGET->ST_MODIFIED} ||= 0;
743        $stat_of{$key}{n}{$ctx->CTX_TARGET->ST_UNCHANGED} ||= 0;
744        $stat_of{$key}{n}{$ctx->CTX_TARGET->ST_FAILED} ||= 0;
745        $stat_of{$key}{t} ||= 0.0;
746        $EVENT->(
747            FCM::Context::Event->MAKE_BUILD_TARGET_TASK_SUMMARY,
748            $key,
749            $stat_of{$key}{n}{$ctx->CTX_TARGET->ST_MODIFIED},
750            $stat_of{$key}{n}{$ctx->CTX_TARGET->ST_UNCHANGED},
751            $stat_of{$key}{n}{$ctx->CTX_TARGET->ST_FAILED},
752            $stat_of{$key}{t},
753        );
754    }
755    $EVENT->(
756        FCM::Context::Event->MAKE_BUILD_TARGET_SUMMARY,
757        scalar(grep {$_->is_modified() } @targets),
758        scalar(grep {$_->is_unchanged()} @targets),
759        scalar(grep {$_->is_failed()   } @targets),
760        $timer->(),
761    );
762    my @failed_targets = grep {$_->is_failed()} @targets;
763    if (@failed_targets) {
764        $EVENT->(
765            FCM::Context::Event->MAKE_BUILD_TARGETS_FAIL,
766            \@failed_targets
767        );
768        _finally($attrib_ref, $m_ctx, $ctx);
769        die("\n");
770    }
771    _finally($attrib_ref, $m_ctx, $ctx);
772}
773
774# Updates a target.
775sub _target_update {
776    my ($attrib_ref, $checksum_method, $target) = @_;
777    my $file_type_util = $attrib_ref->{file_type_util_of}{$target->get_type()};
778    eval {$file_type_util->task_of()->{$target->get_task()}->main($target)};
779    if ($@) {
780        if ($target->get_path() && -e $target->get_path()) {
781            unlink($target->get_path());
782        }
783        die($@);
784    }
785    if (! -e $target->get_path()) {
786        return $E->throw($E->BUILD_TARGET, $target);
787    }
788    $target->set_status($target->ST_MODIFIED);
789    my $checksum = $UTIL->file_checksum($target->get_path(), $checksum_method);
790    if ($target->get_checksum() && $checksum eq $target->get_checksum()) {
791        $target->set_status($target->ST_UNCHANGED);
792        if ($target->get_path_of_prev()) {
793            $target->set_path($target->get_path_of_prev());
794        }
795    }
796    $target->set_checksum($checksum);
797    $target->set_prop_of_prev_of({}); # unset
798    $target->set_path_of_prev(undef); # unset
799}
800
801# Returns the get/put functions to send/receive targets to update.
802sub _targets_manager_funcs {
803    my ($attrib_ref, $m_ctx, $ctx, $stat_hash_ref) = @_;
804
805    my @targets;
806    _targets_from_sources($attrib_ref, $m_ctx, $ctx, \@targets);
807    _targets_props_assign($attrib_ref, $m_ctx, $ctx, \@targets);
808
809    my ($stack_ref, $state_hash_ref)
810        = _targets_select($attrib_ref, $m_ctx, $ctx, \@targets);
811
812    my $checksum_method = _prop($attrib_ref, 'checksum-method', $ctx);
813    my $get_action_ref = sub {
814        STATE:
815        while (my $state = pop(@{$stack_ref})) {
816            if (    !$state->is_ready()
817                ||  !_target_deps_are_done($state, $state_hash_ref, $stack_ref)
818            ) {
819                next STATE;
820            }
821            my $target = $state->get_target();
822            if (_target_check_failed_dep($state, $state_hash_ref)) {
823                _target_update_failed(
824                    $stat_hash_ref, $ctx, $target, $state_hash_ref, $stack_ref,
825                );
826            }
827            elsif (_target_check_ood($state, $state_hash_ref, $checksum_method)) {
828                _target_prep($state, $ctx);
829                $state->set_value($STATE->PENDING);
830                # Adds tasks that can be triggered by this task
831                for my $key (sort @{$target->get_triggers()}) {
832                    if (    exists($state_hash_ref->{$key})
833                        &&  !$state_hash_ref->{$key}->is_done()
834                        &&  !grep {$_->get_id() eq $key} @{$stack_ref}
835                    ) {
836                        my $trigger_target
837                            = $state_hash_ref->{$key}->get_target();
838                        $trigger_target->set_status($trigger_target->ST_OOD);
839                        push(@{$stack_ref}, $state_hash_ref->{$key});
840                    }
841                }
842                return FCM::Context::Task->new(
843                    {ctx => $target, id => $state->get_id()},
844                );
845            }
846            else {
847                _target_update_ok(
848                    $stat_hash_ref, $ctx, $target, $state_hash_ref, $stack_ref,
849                );
850            }
851        }
852        return;
853    };
854    my $put_action_ref = sub {
855        my $task = shift();
856        my $target = $task->get_ctx();
857        if ($task->get_state() eq $task->ST_FAILED) {
858            $EVENT->(FCM::Context::Event->E, $task->get_error());
859            _target_update_failed(
860                $stat_hash_ref, $ctx, $target, $state_hash_ref, $stack_ref,
861                $task->get_elapse(),
862            );
863        }
864        else {
865            my $target = $task->get_ctx();
866            _target_update_ok(
867                $stat_hash_ref, $ctx, $target, $state_hash_ref, $stack_ref,
868                $task->get_elapse(),
869            );
870        }
871    };
872    ($get_action_ref, $put_action_ref);
873}
874
875# Determines and returns the targets from the sources.
876sub _targets_from_sources {
877    my ($attrib_ref, $m_ctx, $ctx, $targets_ref) = @_;
878    my %FILE_TYPE_UTIL_OF = %{$attrib_ref->{file_type_util_of}};
879    my %FILE_EXT_OF;
880    my %FILE_NAME_OPTION_OF;
881    for my $FILE_TYPE_UTIL (values(%FILE_TYPE_UTIL_OF)) {
882        while (my $key = each(%{$FILE_TYPE_UTIL->target_file_ext_of()})) {
883            $FILE_EXT_OF{$key} ||= _prop($attrib_ref, 'file-ext.' . $key, $ctx);
884        }
885        while (my $key = each(%{$FILE_TYPE_UTIL->target_file_name_option_of()})) {
886            $FILE_NAME_OPTION_OF{$key}
887                ||= _prop($attrib_ref, 'file-name-option.' . $key, $ctx);
888        }
889    }
890    # Determine the targets for each source
891    SOURCE:
892    while (my ($ns, $source) = each(%{$ctx->get_source_of()})) {
893        my $type = $source->get_type();
894        $type ||= q{};
895        if (!exists($FILE_TYPE_UTIL_OF{$type})) {
896            next SOURCE;
897        }
898        my $FILE_TYPE_UTIL = $FILE_TYPE_UTIL_OF{$type};
899        if (!$FILE_TYPE_UTIL->can('source_to_targets')) {
900            next SOURCE;
901        }
902        for my $target (
903            $FILE_TYPE_UTIL->source_to_targets(
904                $source, \%FILE_EXT_OF, \%FILE_NAME_OPTION_OF)
905        ) {
906            my $key = $target->get_key();
907            if (exists($ctx->get_target_key_of()->{$key})) {
908                $key = $ctx->get_target_key_of()->{$key};
909                $target->set_key($key);
910            }
911            push(@{$targets_ref}, $target);
912            $target->set_ns($ns);
913            $target->set_path(
914                catfile($ctx->get_dest(), $target->get_category(), $key),
915            );
916            $target->set_path_of_source($source->get_path());
917            $target->set_type($type);
918            if (!$source->get_up_to_date()) {
919                $target->set_status($target->ST_OOD);
920            }
921        }
922    }
923    # Determines name-space dependencies
924    my %deps_in_ns_in_cat_of; # $cat => {$ns => [$targets ...]}
925    FILE_TYPE_UTIL:
926    while (my ($type, $FILE_TYPE_UTIL) = each(%FILE_TYPE_UTIL_OF)) {
927        if (!$FILE_TYPE_UTIL->can('ns_targets')) {
928            next FILE_TYPE_UTIL;
929        }
930        for my $cat ($FILE_TYPE_UTIL->ns_targets_deps()) {
931            $deps_in_ns_in_cat_of{$cat} = {};
932        }
933        for my $target (
934            $FILE_TYPE_UTIL->ns_targets(
935                $targets_ref, \%FILE_EXT_OF, \%FILE_NAME_OPTION_OF)
936        ) {
937            my $key = $target->get_key();
938            if (exists($ctx->get_target_key_of()->{$key})) {
939                $key = $ctx->get_target_key_of()->{$key};
940                $target->set_key($key);
941            }
942            push(@{$targets_ref}, $target);
943            $target->set_type($type);
944            $target->set_path(
945                catfile($ctx->get_dest(), $target->get_category(), $key),
946            );
947        }
948    }
949    for my $target (
950        sort {
951            $a->get_ns() cmp $b->get_ns() || $a->get_key() cmp $b->get_key();
952        } @{$targets_ref}
953    ) {
954        $EVENT->(
955            FCM::Context::Event->MAKE_BUILD_TARGET_FROM_NS,
956            ($target->get_ns() ? $target->get_ns() : '/'),
957            $target->get_task(),
958            $target->get_category(),
959            $target->get_key(),
960        );
961    }
962    # Target categories and name-spaces.
963    for my $target (@{$targets_ref}) {
964        my $cat = $target->get_category();
965        if ($cat && exists($deps_in_ns_in_cat_of{$cat})) {
966            my $ns_iter = $UTIL->ns_iter($target->get_ns(), $UTIL->NS_ITER_UP);
967            # $ns_iter->(); # discard
968            while (defined(my $ns = $ns_iter->())) {
969                $deps_in_ns_in_cat_of{$cat}{$ns} ||= [];
970                push(@{$deps_in_ns_in_cat_of{$cat}{$ns}}, $target->get_key());
971            }
972        }
973    }
974
975    my %CTX_PROP_OF = %{$ctx->get_prop_of()};
976    for my $target (@{$targets_ref}) {
977        my $key = $target->get_key();
978        # Adds categorised name-space dependencies.
979        if (exists($target->get_info_of()->{'deps'})) {
980            CATEGORY:
981            while (my ($cat, $deps_in_ns_ref) = each(%deps_in_ns_in_cat_of)) {
982                if (!exists($target->get_info_of()->{'deps'}{$cat})) {
983                    next CATEGORY;
984                }
985                my $cfg_key = 'ns-dep.' . $cat;
986                my @ns_list = map {$_ eq q{/} ? q{} : $_}
987                    _props($attrib_ref, $cfg_key, $ctx, $target->get_ns());
988                for my $ns (@ns_list) {
989                    if (exists($deps_in_ns_ref->{$ns})) {
990                        push(
991                            @{$target->get_deps()},
992                            (   map  {[$_, $cat]}
993                                grep {$_ ne $key}
994                                @{$deps_in_ns_ref->{$ns}}
995                            ),
996                        );
997                    }
998                    else {
999                        # This will be reported later as missing dependency
1000                        push(@{$target->get_deps()}, [$ns, $cat, 'ns-dep']);
1001                    }
1002                }
1003            }
1004        }
1005        # Remove target dependencies, if necessary
1006        my @deps;
1007        DEP:
1008        for my $dep (@{$target->get_deps()}) {
1009            my ($dep_key, $dep_type) = @{$dep};
1010            my $cfg_key = 'no-dep.' . $dep_type;
1011            if (    !exists($CTX_PROP_OF{$cfg_key})
1012                ||  !exists($CTX_PROP_OF{$cfg_key}->get_ctx_of()->{$key})
1013            ) {
1014                push(@deps, $dep);
1015                next DEP;
1016            }
1017            my @no_dep_keys = shellwords(
1018                $CTX_PROP_OF{$cfg_key}->get_ctx_of()->{$key}->get_value());
1019            if (!grep {$_ eq $dep_key} @no_dep_keys) {
1020                push(@deps, $dep);
1021                next DEP;
1022            }
1023        }
1024        $target->set_deps(\@deps);
1025        # Add target dependencies, if necessary
1026        for my $dep_type (keys(%{$target->get_dep_policy_of()})) {
1027            my $cfg_key = 'dep.' . $dep_type;
1028            if (    exists($CTX_PROP_OF{$cfg_key})
1029                &&  exists($CTX_PROP_OF{$cfg_key}->get_ctx_of()->{$key})
1030            ) {
1031                my @dep_keys = shellwords(
1032                    $CTX_PROP_OF{$cfg_key}->get_ctx_of()->{$key}->get_value());
1033                for my $dep_key (@dep_keys) {
1034                    push(@{$target->get_deps()}, [$dep_key, $dep_type]);
1035                }
1036            }
1037        }
1038    }
1039}
1040
1041# Stores the properties relevant to the target.
1042# Assigns previous checksum and properties, where appropriate.
1043sub _targets_props_assign {
1044    my ($attrib_ref, $m_ctx, $ctx, $targets_ref) = @_;
1045    my $P_TARGET_GETTER
1046        = _prev_hash_item_getter($m_ctx, $ctx, sub {$_[0]->get_target_of()});
1047    my %NO_INHERIT_CATEGORY_IN
1048        = map {$_ => 1} _props($attrib_ref, 'no-inherit-target-category', $ctx);
1049    my %CTX_PROP_OF = %{$ctx->get_prop_of()};
1050    for my $target (@{$targets_ref}) {
1051        my $key = $target->get_key();
1052        # Properties
1053        my $FILE_TYPE_UTIL
1054            = $attrib_ref->{file_type_util_of}->{$target->get_type()};
1055        my $task = $FILE_TYPE_UTIL->task_of()->{$target->get_task()};
1056        if ($task->can('prop_of')) {
1057            my %prop_of = %{$task->prop_of($target)};
1058            while (my $name = each(%prop_of)) {
1059                if (    exists($CTX_PROP_OF{$name})
1060                    &&  exists($CTX_PROP_OF{$name}->get_ctx_of()->{$key})
1061                ) {
1062                    $target->get_prop_of()->{$name}
1063                        = $CTX_PROP_OF{$name}->get_ctx_of()->{$key}->get_value();
1064                }
1065                else {
1066                    $target->get_prop_of()->{$name}
1067                        = _prop($attrib_ref, $name, $ctx, $target->get_ns());
1068                }
1069            }
1070        }
1071        if ($FILE_TYPE_UTIL->can('target_deps_filter')) {
1072            $FILE_TYPE_UTIL->target_deps_filter($target);
1073        }
1074        # Path, checksum and previous properties
1075        my $p_target = $P_TARGET_GETTER->($key);
1076        if (defined($p_target)) {
1077            $target->set_checksum($p_target->get_checksum());
1078            if ($p_target->is_ok()) {
1079                $target->set_path_of_prev($p_target->get_path());
1080                $target->set_prop_of_prev_of($p_target->get_prop_of());
1081            }
1082            else {
1083                $target->set_path_of_prev($p_target->get_path_of_prev());
1084                $target->set_prop_of_prev_of($p_target->get_prop_of_prev_of());
1085                $target->set_status($target->ST_OOD);
1086            }
1087            if (exists($NO_INHERIT_CATEGORY_IN{$target->get_category()})) {
1088                $target->set_path_of_prev($target->get_path());
1089            }
1090        }
1091    }
1092}
1093
1094# Selects targets to update.
1095sub _targets_select {
1096    my ($attrib_ref, $m_ctx, $ctx, $targets_ref) = @_;
1097    my $time = time();
1098    my $timer = $UTIL->timer();
1099    my %select_by = %{$ctx->get_target_select_by()};
1100    my %target_of;
1101    my %targets_of;
1102    my %target_set;
1103    my %has_ns_in; # available sets of name-spaces
1104    for my $target (@{$targets_ref}) {
1105        ATTR_NAME:
1106        for (
1107            #$attr_name, $attr_func
1108            ['key'     , sub {$_[0]->get_key()}],
1109            ['category', sub {$_[0]->get_category()}],
1110            ['task'    , sub {$_[0]->get_task()}],
1111        ) {
1112            my ($attr_name, $attr_func) = @{$_};
1113            for my $ns (sort keys(%{$select_by{$attr_name}})) {
1114                my %attr_set = %{$select_by{$attr_name}->{$ns}};
1115                if (    exists($attr_set{$attr_func->($target)})
1116                    &&  (!$ns || $UTIL->ns_in_set($target->get_ns(), {$ns => 1}))
1117                ) {
1118                    $target_set{$target->get_key()} = 1;
1119                    last ATTR_NAME;
1120                }
1121            }
1122        }
1123        if (exists($target_of{$target->get_key()})) {
1124            if (!exists($targets_of{$target->get_key()})) {
1125                $targets_of{$target->get_key()}
1126                    = [delete($target_of{$target->get_key()})];
1127            }
1128            push(@{$targets_of{$target->get_key()}}, $target);
1129        }
1130        else {
1131            $target_of{$target->get_key()} = $target;
1132        }
1133        # Name-spaces
1134        my $ns_iter = $UTIL->ns_iter($target->get_ns(), $UTIL->NS_ITER_UP);
1135        NS:
1136        while (defined(my $ns = $ns_iter->())) {
1137            if (exists($has_ns_in{$ns})) {
1138                last NS;
1139            }
1140            $has_ns_in{$ns} = 1;
1141        }
1142    }
1143    my @target_keys = sort keys(%target_set);
1144
1145    # Wraps each relevant target with a state object.
1146    # Walks the target dependency tree to build a state dependency tree.
1147    # Checks for missing dependencies.
1148    # Checks for duplicated target.
1149    my @items = map {[[$_, undef]]} @target_keys;
1150    my %state_of;
1151    my %dup_in;
1152    my %cyc_in;
1153    my %missing_deps_in;
1154    ITEM:
1155    while (my $item = pop(@items)) {
1156        my ($unit, @up_units) = @{$item};
1157        my ($key, $type) = @{$unit};
1158        my @up_keys = map {$_->[0]} @up_units;
1159        if (   exists($cyc_in{$key})
1160            || exists($dup_in{$key})
1161            || exists($missing_deps_in{$key})
1162        ) {
1163            next ITEM;
1164        }
1165        if (exists($state_of{$key})) {
1166            # Already visited this ITEM
1167            # Detect cyclic dependency
1168            if (    !$state_of{$key}->get_cyclic_ok()
1169                &&  grep {$_->[0] eq $key} @up_units
1170            ) {
1171                my @_up_units = (@up_units, $unit);
1172                my $_up_unit_last = pop(@_up_units);
1173                DEP_UP_KEY:
1174                while (my $_up_unit = pop(@_up_units)) {
1175                    my ($_up_key, $_up_type) = @{$_up_unit};
1176                    my @dep_up_deps = @{$state_of{$_up_key}->get_deps()};
1177                    # If parent of $_up_unit_last does not depend on
1178                    # $_up_unit_last, chain is broken, and we are OK.
1179                    my ($_up_key_last, $_up_type_last) = @{$_up_unit_last};
1180                    if (!grep {     $_->[0]->get_key() eq $_up_key_last
1181                                ||  $_->[1] eq $_up_type_last
1182                        } @dep_up_deps
1183                    ) {
1184                        last DEP_UP_KEY;
1185                    }
1186                    if ($type && $key eq $_up_key && $type eq $_up_type) {
1187                        $cyc_in{$key} = {'keys' => [@up_keys, $key]};
1188                        next ITEM;
1189                    }
1190                    $_up_unit_last = $_up_unit;
1191                }
1192            }
1193            $state_of{$key}->set_cyclic_ok(1);
1194            # Float current target up dependency chain
1195            my $is_directly_related = 1;
1196            UP_KEY:
1197            for my $up_key (reverse(@up_keys)) {
1198                if ($state_of{$up_key}->add_visitor(
1199                        $state_of{$key}->get_target(),
1200                        $type,
1201                        $is_directly_related,
1202                )) {
1203                    last UP_KEY;
1204                }
1205                $is_directly_related = 0;
1206            }
1207            # Add floatable dependencies up the dependency chain
1208            for my $visitor (values(%{$state_of{$key}->get_floatables()})) {
1209                UP_KEY:
1210                for my $up_key (reverse(@up_keys)) {
1211                    if ($state_of{$up_key}->add_visitor(@{$visitor})) {
1212                        last UP_KEY;
1213                    }
1214                }
1215            }
1216            next ITEM;
1217        }
1218
1219        # First visit to this ITEM
1220        # Checks for duplicated target
1221        if (exists($targets_of{$key})) {
1222            $dup_in{$key} = {
1223                'keys' => [@up_keys, $key],
1224                'values' => [map {$_->get_ns()} @{$targets_of{$key}}],
1225            };
1226            next ITEM;
1227        }
1228        # Wraps all required targets with a STATE object
1229        $state_of{$key} = $STATE->new(
1230            {id => $key, target => $target_of{$key}},
1231        );
1232        my $target = $target_of{$key};
1233        DEP:
1234        for (
1235            grep {$_->[0] ne $key}
1236            sort {$a->[0] cmp $b->[0]}
1237            @{$target->get_deps()}
1238        ) {
1239            my ($dep_key, $dep_type, $dep_remark) = @{$_};
1240            # Duplicated targets
1241            if (exists($targets_of{$dep_key})) {
1242                $dup_in{$dep_key} = {
1243                    'keys' => [@up_keys, $key, $dep_key],
1244                    'values' => [map {$_->get_ns()} @{$targets_of{$dep_key}}],
1245                };
1246                next DEP;
1247            }
1248            # Missing dependency
1249            if (!exists($target_of{$dep_key})) {
1250                if (!exists($missing_deps_in{$key})) {
1251                    $missing_deps_in{$key} = {
1252                        'keys'   => [@up_keys, $key, $dep_key],
1253                        'values' => [],
1254                    };
1255                }
1256                push(
1257                    @{$missing_deps_in{$key}{'values'}},
1258                    [$dep_key, $dep_type, $dep_remark],
1259                );
1260                next DEP;
1261            }
1262            # OK
1263            push(@items, [[$dep_key, $dep_type], @up_units, [$key, $type]]);
1264            # add_visitor, is_directly_related=1
1265            $state_of{$key}->add_visitor($target_of{$dep_key}, $dep_type, 1)
1266        }
1267        # Float current target up dependency chain
1268        my $is_directly_related = 1;
1269        UP_KEY:
1270        for my $up_key (reverse(@up_keys)) {
1271            if ($state_of{$up_key}->add_visitor(
1272                    $target, $type, $is_directly_related,
1273            )) {
1274                last UP_KEY;
1275            }
1276            $is_directly_related = 0;
1277        }
1278        # Adds triggers
1279        for my $trigger_key (@{$target->get_triggers()}) {
1280            if (!exists($state_of{$trigger_key})) {
1281                unshift(@items, [[$trigger_key, undef]]);
1282            }
1283        }
1284    }
1285    # Visitors no longer used
1286    for my $state (values(%state_of)) {
1287        $state->free_visitors();
1288    }
1289    # Assigns targets to build context
1290    %{$ctx->get_target_of()}
1291        = map {($_->get_id() => $_->get_target())} values(%state_of);
1292
1293    # Report cyclic dependencies
1294    # Report duplicated targets
1295    # Report missing dependencies
1296    # Report bad keys in target select
1297    if (keys(%cyc_in)) {
1298        return $E->throw($E->BUILD_TARGET_CYC, \%cyc_in);
1299    }
1300    if (keys(%dup_in)) {
1301        return $E->throw($E->BUILD_TARGET_DUP, \%dup_in);
1302    }
1303    my @ignore_missing_dep_ns_list = map {$_ eq q{/} ? q{} : $_} (
1304        _props($attrib_ref, 'ignore-missing-dep-ns', $ctx)
1305    );
1306    KEY:
1307    for my $key (sort(keys(%missing_deps_in))) {
1308        my $target = $target_of{$key};
1309        for my $ns (@ignore_missing_dep_ns_list) {
1310            if ($UTIL->ns_common($ns, $target->get_ns()) eq $ns) { # target in ns
1311                my $hash_ref = delete($missing_deps_in{$key});
1312                my @deps = @{$hash_ref->{"values"}};
1313                for my $dep (@deps) {
1314                    $EVENT->(
1315                        FCM::Context::Event->MAKE_BUILD_TARGET_MISSING_DEP,
1316                        $key, @{$dep},
1317                    );
1318                }
1319                next KEY;
1320            }
1321        }
1322    }
1323    if (keys(%missing_deps_in)) {
1324        return $E->throw($E->BUILD_TARGET_DEP, \%missing_deps_in);
1325    }
1326    if (exists($select_by{key}{q{}})) {
1327        my @bad_keys = grep {!exists($state_of{$_})} keys(%{$select_by{key}{q{}}});
1328        if (@bad_keys) {
1329            return $E->throw($E->BUILD_TARGET_BAD, \@bad_keys);
1330        }
1331    }
1332    # Walk the tree and report it
1333    my @report_items = map {[$_]} sort @target_keys;
1334    my %reported;
1335    ITEM:
1336    while (my $item = pop(@report_items)) {
1337        my ($key, @stack) = @{$item};
1338        my @deps = sort {$a->[0]->get_key() cmp $b->[0]->get_key()}
1339            @{$state_of{$key}->get_deps()};
1340        my @more_items = reverse(map {[$_->[0]->get_key(), @stack, $key]} @deps);
1341        my $n_more_items;
1342        if (exists($reported{$key})) {
1343            $n_more_items = scalar(@more_items);
1344        }
1345        else {
1346            push(@report_items, @more_items);
1347        }
1348        $attrib_ref->{util}->event(
1349            FCM::Context::Event->MAKE_BUILD_TARGET_STACK,
1350            $key, scalar(@stack), $n_more_items,
1351        );
1352        $reported{$key} = 1;
1353    }
1354    $EVENT->(
1355        FCM::Context::Event->MAKE_BUILD_TARGET_SELECT,
1356        {map {$_ => $target_of{$_}} @target_keys},
1357    );
1358    # TODO: error if nothing to build?
1359
1360    # Checks whether properties with name-spaces are valid.
1361    my @invalid_prop_ns_list;
1362    while (my ($name, $prop) = each(%{$ctx->get_prop_of()})) {
1363        while (my ($ns, $prop_ctx) = each(%{$prop->get_ctx_of()})) {
1364            if (    !$prop_ctx->get_inherited()
1365                &&  !exists($target_of{$ns})
1366                &&  !exists($has_ns_in{$ns})
1367            ) {
1368                push(
1369                    @invalid_prop_ns_list,
1370                    [$ctx->get_id(), $name, $ns, $prop_ctx->get_value()],
1371                );
1372            }
1373        }
1374    }
1375    if (@invalid_prop_ns_list) {
1376        return $E->throw($E->MAKE_PROP_NS, \@invalid_prop_ns_list);
1377    }
1378
1379    $EVENT->(FCM::Context::Event->MAKE_BUILD_TARGET_SELECT_TIMER, $timer->());
1380
1381    # Returns list of keys of top targets, and the states
1382    ([map {$state_of{$_}} reverse(@target_keys)], \%state_of);
1383}
1384
1385# Returns true if $target dependencies are done.
1386sub _target_deps_are_done {
1387    my ($state, $state_hash_ref, $stack_ref) = @_;
1388    my @deps = map {[$_->[0]->get_key(), $_->[1]]} @{$state->get_deps()};
1389    for my $k (sort grep {$state_hash_ref->{$_}->is_ready()} map {$_->[0]} @deps) {
1390        if (!grep {$_->get_id() eq $k} @{$stack_ref}) {
1391            push(@{$stack_ref}, $state_hash_ref->{$k});
1392        }
1393    }
1394    my %not_done
1395        = map  {@{$_}}
1396          grep {!$_->[1]->is_done()}
1397          map  {[$_->[0], $state_hash_ref->{$_->[0]}]}
1398          @deps;
1399    if (keys(%not_done)) {
1400        $state->set_value($STATE->PENDING);
1401        while (my ($k, $s) = each(%not_done)) {
1402            $state->get_pending_for()->{$k} = $s;
1403            $s->get_needed_by()->{$state->get_id()} = $state;
1404        }
1405        return 0;
1406    }
1407    return 1;
1408}
1409
1410# Returns true if $target has failed dependencies.
1411sub _target_check_failed_dep {
1412    my ($state, $state_hash_ref) = @_;
1413    my $target = $state->get_target();
1414    for my $dep (@{$state->get_deps()}) {
1415        my ($target_of_dep, $type_of_dep) = @{$dep};
1416        if ($target_of_dep->is_failed()) {
1417            return 1;
1418        }
1419        if (    exists($target_of_dep->get_status_of()->{$type_of_dep})
1420            &&  $target_of_dep->get_status_of()->{$type_of_dep}
1421                    eq $target->ST_FAILED
1422        ) {
1423            return 1;
1424        }
1425    }
1426    return 0;
1427}
1428
1429# Returns true if $target is out of date.
1430sub _target_check_ood {
1431    my ($state, $state_hash_ref, $checksum_method) = @_;
1432    my $target = $state->get_target();
1433    # Dependencies
1434    my $rc;
1435    for my $dep (@{$state->get_deps()}) {
1436        my ($target_of_dep, $type_of_dep) = @{$dep};
1437        if (    $target_of_dep->is_modified()
1438            ||  exists($target_of_dep->get_status_of()->{$type_of_dep})
1439                &&  $target_of_dep->get_status_of()->{$type_of_dep}
1440                    eq $target->ST_MODIFIED
1441        ) {
1442            if (exists($target->get_status_of()->{$type_of_dep})) {
1443                $target->get_status_of()->{$type_of_dep} = $target->ST_MODIFIED;
1444                if (    $target->get_path_of_prev()
1445                    &&  $target->get_path() ne $target->get_path_of_prev()
1446                ) {
1447                    # Inherited build, cannot just pass on a status
1448                    $rc = 1;
1449                }
1450            }
1451            else {
1452                $rc = 1;
1453            }
1454        }
1455    }
1456    if ($rc || $target->get_status() eq $target->ST_OOD) {
1457        return 1;
1458    }
1459    # Dest and properties
1460    my $path_of_prev = $target->get_path_of_prev();
1461    my $checksum = $target->get_checksum();
1462    my $prop_hash_ref = $target->get_prop_of();
1463    my $prop_of_prev_hash_ref = $target->get_prop_of_prev_of();
1464    (       !$path_of_prev
1465        ||  !-e $path_of_prev
1466        ||  $UTIL->file_checksum($path_of_prev, $checksum_method) ne $checksum
1467        ||  $UTIL->hash_cmp($prop_hash_ref, $prop_of_prev_hash_ref)
1468    );
1469}
1470
1471# Callback to prepare the target for the task.
1472sub _target_prep {
1473    my ($state, $ctx) = @_;
1474    my $target = $state->get_target();
1475    # Creates the container directory, where necessary
1476    my %paths_of_dirs_set;
1477    for my $t (
1478        $target,
1479        map {$ctx->get_target_of($_)} @{$target->get_triggers()},
1480    ) {
1481        $paths_of_dirs_set{dirname($t->get_path())} = 1;
1482    }
1483    for my $path_of_dir (keys(%paths_of_dirs_set)) {
1484        if (!-d $path_of_dir) {
1485            eval {mkpath($path_of_dir)};
1486            if ($@) {
1487                return $E->throw($E->DEST_CREATE, $path_of_dir);
1488            }
1489        }
1490    }
1491    # Put in required info
1492    if ($target->get_info_of('paths')) {
1493        @{$target->get_info_of('paths')} = @{$ctx->get_dests()};
1494    }
1495    if ($target->get_info_of('deps')) {
1496        my $info_deps_ref = $target->get_info_of('deps');
1497        my %set_of = map {$_ => {}} keys(%{$info_deps_ref});
1498        for my $dep (@{$state->get_deps()}) {
1499            my ($target_of_dep, $type) = @{$dep};
1500            my $key = $target_of_dep->get_key();
1501            if (exists($set_of{$type}) && !$set_of{$type}{$key}) {
1502                if ($target_of_dep->get_ns() eq $target->get_ns()) {
1503                    # E.g. main *.o of *.exe
1504                    unshift(@{$info_deps_ref->{$type}}, $key);
1505                }
1506                else {
1507                    push(@{$info_deps_ref->{$type}}, $key);
1508                }
1509                $set_of{$type}{$key} = 1;
1510            }
1511        }
1512    }
1513}
1514
1515# Sets state and stack when a $target has failed to update or cannot be updated
1516# due to failed dependencies.
1517sub _target_update_failed {
1518    my ($stat_hash_ref,
1519        $ctx,
1520        $target,
1521        $state_hash_ref,
1522        $stack_ref,
1523        $elapsed_time, # only defined if target update action is done
1524    ) = @_;
1525    my $key = $target->get_key();
1526    my $state = $state_hash_ref->{$key};
1527    $state->set_value($STATE->DONE);
1528    # If this target is needed by other targets...
1529    while (my ($k, $s) = each(%{$state->get_needed_by()})) {
1530        my $pending_for_ref = $s->get_pending_for();
1531        delete($pending_for_ref->{$key});
1532        if (!keys(%{$pending_for_ref})) {
1533            $s->set_value($STATE->DONE);
1534            # Remove from stack
1535            @{$stack_ref} = grep {$_->get_id() ne $k} @{$stack_ref};
1536            $s->get_target()->set_status($target->ST_FAILED);
1537            push(@{$s->get_target()->get_failed_by()}, $key);
1538        }
1539    }
1540    if (defined($elapsed_time)) { # Done target update
1541        my $target0 = $ctx->get_target_of()->{$target->get_key()};
1542        $target0->set_info_of({}); # unset
1543        $target0->set_checksum(undef);
1544        $target0->set_path(undef);
1545        $target0->set_prop_of_prev_of({}); # unset
1546        $target0->set_path_of_prev(undef); # unset
1547        $target0->set_status($target->ST_FAILED);
1548        push(@{$target0->get_failed_by()}, $target->get_key());
1549        ++$stat_hash_ref->{$target->get_task()}{n}{$target->ST_FAILED};
1550        $stat_hash_ref->{$target->get_task()}{t} += $elapsed_time;
1551    }
1552    else { # No target update required
1553        $target->set_path(undef);
1554        $target->set_prop_of_prev_of({}); # unset
1555        $target->set_path_of_prev(undef); # unset
1556        $target->set_status($target->ST_FAILED);
1557        for my $dep (@{$state->get_deps()}) {
1558            my ($dep_target, $dep_type) = @{$dep};
1559            my $dep_key = $dep_target->get_key();
1560            if (    $dep_target->is_failed()
1561                &&  !grep {$_ eq $dep_key} @{$target->get_failed_by()}
1562            ) {
1563                push(@{$target->get_failed_by()}, $dep_key);
1564            }
1565        }
1566        ++$stat_hash_ref->{$target->get_task()}{n}{$target->ST_FAILED};
1567    }
1568    $EVENT->(
1569        FCM::Context::Event->MAKE_BUILD_TARGET_FAIL, $target, $elapsed_time,
1570    );
1571}
1572
1573# Sets state and stack when a $target is up to date or updated successfully.
1574sub _target_update_ok {
1575    my ($stat_hash_ref,
1576        $ctx,
1577        $target,
1578        $state_hash_ref,
1579        $stack_ref,
1580        $elapsed_time, # only defined if target update action is done
1581    ) = @_;
1582    my $key = $target->get_key();
1583    my $state = $state_hash_ref->{$key};
1584    $state->set_value($STATE->DONE);
1585    # If this target is needed by other targets...
1586    my @released_pending_states;
1587    while (my ($k, $s) = each(%{$state->get_needed_by()})) {
1588        my $pending_for_ref = $s->get_pending_for();
1589        delete($pending_for_ref->{$key});
1590        if ($s->is_pending() && !keys(%{$pending_for_ref})) {
1591            $s->set_value($STATE->READY);
1592            if (!grep {$_->get_id() eq $k} @{$stack_ref}) {
1593                push(@released_pending_states, $s);
1594            }
1595        }
1596    }
1597    push(
1598        @{$stack_ref},
1599        sort {$a->get_id() cmp $b->get_id()} @released_pending_states,
1600    );
1601    if (defined($elapsed_time)) { # Done target update
1602        my $target0 = $ctx->get_target_of()->{$target->get_key()};
1603        $target0->set_info_of({}); # unset
1604        $target0->set_checksum($target->get_checksum());
1605        $target0->set_path($target->get_path());
1606        $target0->set_prop_of_prev_of({}); # unset
1607        $target0->set_path_of_prev(undef); # unset
1608        $target0->set_status($target->get_status());
1609        ++$stat_hash_ref->{$target->get_task()}{n}{$target->get_status()};
1610        $stat_hash_ref->{$target->get_task()}{t} += $elapsed_time;
1611    }
1612    else { # No target update required
1613        if ($target->get_path_of_prev()) {
1614            $target->set_path($target->get_path_of_prev());
1615        }
1616        $target->set_prop_of_prev_of({}); # unset
1617        $target->set_path_of_prev(undef); # unset
1618        $target->set_status($target->ST_UNCHANGED);
1619        ++$stat_hash_ref->{$target->get_task()}{n}{$target->ST_UNCHANGED};
1620    }
1621    $EVENT->(
1622        FCM::Context::Event->MAKE_BUILD_TARGET_DONE, $target, $elapsed_time,
1623    );
1624}
1625
1626# Returns a list containing the inherited contexts with the same ID as $ctx.
1627sub _i_ctx_list {
1628    my ($m_ctx, $ctx) = @_;
1629    grep
1630        {defined()}
1631    map
1632        {$_->get_ctx_of($ctx->get_id())}
1633    @{$m_ctx->get_inherit_ctx_list()};
1634}
1635
1636# Returns a function that returns the previous source/target of a specified key.
1637sub _prev_hash_item_getter {
1638    my ($m_ctx, $ctx, $getter_ref) = @_;
1639    my $p_m_ctx = $m_ctx->get_prev_ctx();
1640    my %p_item_of;
1641    my $ctx_id = $ctx->get_id();
1642    if (defined($p_m_ctx) && defined($p_m_ctx->get_ctx_of($ctx_id))) {
1643        %p_item_of = %{$getter_ref->($p_m_ctx->get_ctx_of($ctx_id))};
1644    }
1645    else {
1646        for my $i_ctx (_i_ctx_list($m_ctx, $ctx)) {
1647            %p_item_of = (%p_item_of, %{$getter_ref->($i_ctx)});
1648        }
1649    }
1650    sub {exists($p_item_of{$_[0]}) ? $p_item_of{$_[0]} : undef};
1651}
1652
1653# Perform final actions.
1654# Archive intermediate target directories if necessary.
1655sub _finally {
1656    my ($attrib_ref, $m_ctx, $ctx) = @_;
1657    if (!$m_ctx->get_option_of('archive')) {
1658        return;
1659    }
1660    my %can_archive = map {($_ => 1)} _props(
1661        $attrib_ref, 'archive-ok-target-category', $ctx);
1662    opendir(my $handle, $ctx->get_dest());
1663    while (my $name = readdir($handle)) {
1664        if ($can_archive{$name}) {
1665            my @command = (
1666                qw{tar -c -z}, '-C', $ctx->get_dest(),
1667                '-f', catfile($ctx->get_dest(), $name . '.tar.gz'),
1668                $name,
1669            );
1670            my %value_of = %{$UTIL->shell_simple(\@command)};
1671            if ($value_of{'rc'} == 0) {
1672                rmtree(catfile($ctx->get_dest(), $name));
1673            }
1674        }
1675    }
1676    closedir($handle);
1677}
1678
1679# ------------------------------------------------------------------------------
1680package FCM::System::Make::Build::State;
1681use base qw{FCM::Class::HASH};
1682
1683use constant {
1684    DONE       => 'DONE',       # state value
1685    READY      => 'READY',      # state value
1686    PENDING    => 'PENDING',    # state value
1687};
1688
1689__PACKAGE__->class({
1690    cyclic_ok   => '$',
1691    deps        => '@',
1692    floatables  => '%',
1693    id          => '$',
1694    needed_by   => '%',
1695    pending_for => '%',
1696    target      => 'FCM::Context::Make::Build::Target',
1697    value       => {isa => '$', default => READY},
1698    visited_by  => '%',
1699});
1700
1701sub add_visitor {
1702    my ($self, $dep_target, $dep_type, $is_directly_related) = @_;
1703    my $dep_key = $dep_target->get_key();
1704    my $dep_str = join(':', $dep_key, $dep_type);
1705    # Dependency has already visited me, return cached return value
1706    if (exists($self->get_visited_by()->{$dep_str})) {
1707        return $self->get_visited_by()->{$dep_str};
1708    }
1709    # Adopt dep_target as my dependency if there is a policy to do so
1710    my $target = $self->get_target();
1711    my $policy = $target->get_dep_policy_of($dep_type);
1712    if (    $policy
1713        &&  ($policy ne $target->POLICY_FILTER_IMMEDIATE || $is_directly_related)
1714        &&  (!grep {$_->[0]->get_key() eq $dep_key} @{$self->get_deps()})
1715        &&  (!grep {$_ eq $dep_key} @{$target->get_triggers()})
1716    ) {
1717        push(@{$self->get_deps()}, [$dep_target, $dep_type]);
1718    }
1719    # If target is captured by me, return true.
1720    # Otherwise, return false, and the target is a floatable.
1721    $self->get_visited_by()->{$dep_str}
1722        = ($policy && $policy eq $target->POLICY_CAPTURE);
1723    if (    !$self->get_visited_by()->{$dep_str}
1724        &&  !exists($self->get_floatables()->{$dep_str})
1725    ) {
1726        $self->get_floatables()->{$dep_str} = [$dep_target, $dep_type];
1727    }
1728    return $self->get_visited_by()->{$dep_str};
1729}
1730
1731sub free_visitors {
1732    my ($self) = @_;
1733    %{$self->get_floatables()} = ();
1734    %{$self->get_visited_by()} = ();
1735}
1736
1737sub is_done {
1738    $_[0]->{value} eq DONE;
1739}
1740
1741sub is_pending {
1742    $_[0]->{value} eq PENDING;
1743}
1744
1745sub is_ready {
1746    $_[0]->{value} eq READY;
1747}
1748#-------------------------------------------------------------------------------
17491;
1750__END__
1751
1752=head1 NAME
1753
1754FCM::System::Make::Build
1755
1756=head1 SYNOPSIS
1757
1758    use FCM::System::Make::Build;
1759
1760=head1 DESCRIPTION
1761
1762Implements the build sub-system. An instance of this class is expected to be
1763initialised and called by L<FCM::System::Make|FCM::System::Make>.
1764
1765=head1 METHODS
1766
1767See L<FCM::System::Make|FCM::System::Make> for detail.
1768
1769=head1 ATTRIBUTES
1770
1771The $class->new(\%attrib) method of this class supports the following
1772attributes:
1773
1774=over 4
1775
1776=item config_parser_of
1777
1778A HASH to map the labels in a configuration file to their parsers. (default =
1779%FCM::System::Make::Build::CONFIG_PARSER_OF)
1780
1781=item target_select_by
1782
1783A HASH to map the default target selector. The keys should be "category", "key",
1784"ns", or "task". (default = %FCM::System::Make::Build::TARGET_SELECT_by)
1785
1786=item file_type_utils
1787
1788An ARRAY of file type utility classes to be loaded into the file_type_util_of
1789HASH. (default = @FCM::System::Make::Build::FILE_TYPE_UTILS)
1790
1791=item file_type_util_of
1792
1793A HASH to map the file type names to the utilities to manipulate the given file
1794types. An values in this HASH overrides the classes in I<file_type_utils>.
1795(default = determined by I<file_type_utils>)
1796
1797=item prop_of
1798
1799A HASH to map the names of the properties to their settings. Each setting
1800is a 2-element ARRAY reference, where element [0] is the default setting
1801and element [1] is a flag to indicate whether the property accepts a name-space
1802or not. (default = %FCM::System::Make::Build::PROP_OF + values loaded from the
1803file type utilities)
1804
1805=item util
1806
1807See L<FCM::System::Make|FCM::System::Make> for detail.
1808
1809=back
1810
1811=head1 COPYRIGHT
1812
1813(C) Crown copyright Met Office. All rights reserved.
1814
1815=cut
Note: See TracBrowser for help on using the repository browser.