source: LMDZ6/branches/Amaury_dev/tools/fcm/lib/FCM/System/Make.pm @ 5475

Last change on this file since 5475 was 5129, checked in by abarral, 7 months ago

Re-add removed by mistake fcm
File size: 14.2 KB
Line 
1# ------------------------------------------------------------------------------
2# Copyright (C) 2006-2021 British Crown (Met Office) & Contributors.
3#
4# This file is part of FCM, tools for managing and building source code.
5#
6# FCM is free software: you can redistribute it and/or modify
7# it under the terms of the GNU General Public License as published by
8# the Free Software Foundation, either version 3 of the License, or
9# (at your option) any later version.
10#
11# FCM is distributed in the hope that it will be useful,
12# but WITHOUT ANY WARRANTY; without even the implied warranty of
13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14# GNU General Public License for more details.
15#
16# You should have received a copy of the GNU General Public License
17# along with FCM. If not, see <http://www.gnu.org/licenses/>.
18# ------------------------------------------------------------------------------
19use strict;
20use warnings;
21# ------------------------------------------------------------------------------
22package FCM::System::Make;
23use base qw{FCM::Class::CODE};
24
25use FCM::Context::ConfigEntry;
26use FCM::Context::Event;
27use FCM::System::Exception;
28use FCM::System::Make::Build;
29use FCM::System::Make::Extract;
30use FCM::System::Make::Mirror;
31use FCM::System::Make::Preprocess;
32use FCM::System::Make::Share::Config;
33use FCM::System::Make::Share::Dest;
34use File::Basename qw{basename};
35use File::Copy qw{copy};
36use File::Path qw{rmtree};
37use File::Spec::Functions qw{catfile};
38use File::Temp;
39use POSIX qw{strftime};
40use Sys::Hostname qw{hostname};
41
42# Actions of the named common steps
43my %ACTION_OF = (
44    'config-parse' => \&_config_parse,
45    'dest-init'    => \&_dest_init   ,
46);
47# Alias to class name
48my $E = 'FCM::System::Exception';
49# The initial steps to run
50my @INIT_STEPS = (qw{config-parse dest-init});
51# The name of the system
52our $NAME = 'make';
53# Base name of common configuration file
54our $CFG_BASE = 'make.cfg';
55# A map of named helper utilities
56our %SHARED_UTIL_OF = (
57    'config' => 'FCM::System::Make::Share::Config',
58    'dest'   => 'FCM::System::Make::Share::Dest'  ,
59);
60# A map of named subsystems
61our %SUBSYSTEM_OF = (
62    'build'      => 'FCM::System::Make::Build'     ,
63    'extract'    => 'FCM::System::Make::Extract'   ,
64    'mirror'     => 'FCM::System::Make::Mirror'    ,
65    'preprocess' => 'FCM::System::Make::Preprocess',
66);
67
68# Creates the class.
69__PACKAGE__->class(
70    {   cfg_base       => {isa => '$', default => $CFG_BASE},
71        name           => {isa => '$', default => $NAME},
72        shared_util_of => '%',
73        subsystem_of   => '%',
74        util           => '&',
75    },
76    {init => \&_init, action_of => {main => \&_main}},
77);
78
79# Initialises an instance.
80sub _init {
81    my $attrib_ref = shift();
82    for (
83        ['shared_util_of', \%SHARED_UTIL_OF],
84        ['subsystem_of'  , \%SUBSYSTEM_OF  ],
85    ) {
86        my ($key, $hash_ref) = @{$_};
87        while (my ($id, $class) = each(%{$hash_ref})) {
88            if (!exists($attrib_ref->{$key}{$id})) {
89                $attrib_ref->{$key}{$id} = $class->new({
90                    'shared_util_of' => $attrib_ref->{'shared_util_of'},
91                    'subsystem_of'   => $attrib_ref->{'subsystem_of'},
92                    'util'           => $attrib_ref->{'util'},
93                });
94            }
95        }
96    }
97    $attrib_ref->{util}->cfg_init(
98        $attrib_ref->{cfg_base},
99        sub {
100            my $config_reader = shift();
101            my @unknown_entries;
102            while (defined(my $entry = $config_reader->())) {
103                my ($id, $label) = split(qr{\.}msx, $entry->get_label(), 2);
104                if (exists($attrib_ref->{subsystem_of}{$id})) {
105                    my $subsystem = $attrib_ref->{subsystem_of}{$id};
106                    if (!$subsystem->config_parse_class_prop($entry, $label)) {
107                        push(@unknown_entries, $entry);
108                    }
109                }
110                else {
111                    push(@unknown_entries, $entry);
112                }
113            }
114            if (@unknown_entries) {
115                return $E->throw($E->CONFIG_UNKNOWN, \@unknown_entries);
116            }
117        },
118    );
119}
120
121# Sets up the destination.
122sub _config_parse {
123    my ($attrib_ref, $m_ctx, @args) = @_;
124    my $entry_callback_ref = sub {
125        my ($entry) = @_;
126        print({$attrib_ref->{handle_cfg}} $entry->as_string(), "\n");
127    };
128    $attrib_ref->{shared_util_of}{config}->parse(
129        $entry_callback_ref, $m_ctx, @args,
130    );
131}
132
133# Sets up the destination.
134sub _dest_init {
135    my ($attrib_ref, $m_ctx) = @_;
136    my $DEST_UTIL = $attrib_ref->{shared_util_of}{dest};
137    $DEST_UTIL->dest_init($m_ctx);
138
139    # Move temporary log file to destination
140    my $now = strftime("%Y%m%dT%H%M%S", gmtime());
141    my $log = $DEST_UTIL->path($m_ctx, 'sys-log');
142    my $log_actual = sprintf("%s-%s", $log, $now);
143    _symlink(basename($log_actual), $log);
144    (       close($attrib_ref->{handle_log})
145        &&  copy($attrib_ref->{handle_log}->filename(), $log)
146        &&  open(my $handle_log, '>>', $log)
147    ) || return $E->throw($E->DEST_CREATE, $log, $!);
148    _symlink(
149        $DEST_UTIL->path({'name' => $m_ctx->get_name()}, 'sys-log'),
150        $DEST_UTIL->path($m_ctx, 'sys-log-symlink'),
151    );
152    my $log_ctx = $attrib_ref->{util}->util_of_report()->get_ctx($m_ctx);
153    $log_ctx->set_handle($handle_log);
154
155    # Saves as parsed config
156    my $cfg = $DEST_UTIL->path($m_ctx, 'sys-config-as-parsed');
157    (       close($attrib_ref->{handle_cfg})
158        &&  copy($attrib_ref->{handle_cfg}->filename(), $cfg)
159    ) || return $E->throw($E->DEST_CREATE, $cfg, $!);
160    _symlink(
161        $DEST_UTIL->path({'name' => $m_ctx->get_name()}, 'sys-config-as-parsed'),
162        $DEST_UTIL->path($m_ctx, 'sys-config-as-parsed-symlink'),
163    );
164}
165
166# The main function of an instance of this class.
167sub _main {
168    my ($attrib_ref, $option_hash_ref, @args) = @_;
169    my @bad_args;
170    for my $i (0 .. $#args) {
171        if (index($args[$i], "=") < 0) {
172            push(@bad_args, [$i, $args[$i]]);
173        }
174    }
175    if (@bad_args) {
176        return $E->throw($E->MAKE_ARG, \@bad_args);
177    }
178    # Starts the system
179    my $m_ctx = FCM::Context::Make->new({option_of => $option_hash_ref});
180    if ($m_ctx->get_option_of('name')) {
181        $m_ctx->set_name($m_ctx->get_option_of('name'));
182    }
183    my $T = sub {_timer_wrap($attrib_ref, $m_ctx, @_)};
184    my $DEST_UTIL = $attrib_ref->{shared_util_of}{dest};
185    eval {$T->(
186        sub {
187            my %attrib = (
188                %{$attrib_ref},
189                handle_log => File::Temp->new(),
190                handle_cfg => File::Temp->new(),
191            );
192            $attrib_ref->{util}->util_of_report()->add_ctx(
193                $m_ctx, # key
194                {   handle    => $attrib{handle_log},
195                    type      => undef,
196                    verbosity => $attrib_ref->{util}->util_of_report()->HIGH,
197                },
198            );
199            my $version = $attrib_ref->{util}->version();
200            $attrib_ref->{util}->event(
201                FCM::Context::Event->FCM_VERSION, "FCM $version",
202            );
203            for my $step (@INIT_STEPS) {
204                $T->(sub {$ACTION_OF{$step}->(\%attrib, $m_ctx, @args)}, $step);
205            }
206            my $prev_m_ctx = $m_ctx->get_prev_ctx();
207            if (defined($prev_m_ctx)) {
208                for my $step (keys(%{$prev_m_ctx->get_ctx_of()})) {
209                    if (!grep {$_ eq $step} @{$m_ctx->get_steps()}) {
210                        delete($prev_m_ctx->get_ctx_of()->{$step});
211                    }
212                }
213            }
214            for my $step (@{$m_ctx->get_steps()}) {
215                my $ctx = $m_ctx->get_ctx_of($step);
216                if (!defined($ctx)) {
217                    return $E->throw($E->MAKE, $step);
218                }
219                my $id_of_class = $ctx->get_id_of_class();
220                if (!exists($attrib_ref->{subsystem_of}{$id_of_class})) {
221                    return $E->throw($E->MAKE, $step);
222                }
223                my $impl = $attrib_ref->{subsystem_of}{$id_of_class};
224                $ctx->set_status($m_ctx->ST_INIT);
225                if ($ctx->can('set_dest')) {
226                    $ctx->set_dest(
227                        $DEST_UTIL->path($m_ctx, 'target', $ctx->get_id()),
228                    );
229                }
230                eval {$T->(sub {$impl->main($m_ctx, $ctx)}, $step)};
231                if (my $e = $@) {
232                    $ctx->set_status($m_ctx->ST_FAILED);
233                    die($e);
234                }
235                $ctx->set_status($m_ctx->ST_OK);
236                if (    defined($prev_m_ctx)
237                    &&  exists($prev_m_ctx->get_ctx_of()->{$step})
238                ) {
239                    delete($prev_m_ctx->get_ctx_of()->{$step});
240                }
241            }
242        },
243    )};
244    if (my $e = $@) {
245        $m_ctx->set_status($m_ctx->ST_FAILED);
246        $m_ctx->set_error($e);
247        $attrib_ref->{util}->event(FCM::Context::Event->E, $e);
248        _main_finally($attrib_ref, $m_ctx);
249        die("\n");
250    }
251    $m_ctx->set_status($m_ctx->ST_OK);
252    $DEST_UTIL->save(
253        [$attrib_ref->{shared_util_of}{config}->unparse($m_ctx)],
254        $m_ctx,
255        'sys-config-on-success',
256    );
257    _symlink(
258        $DEST_UTIL->path({'name' => $m_ctx->get_name()}, 'sys-config-on-success'),
259        $DEST_UTIL->path($m_ctx, 'sys-config-on-success-symlink'),
260    );
261    _main_finally($attrib_ref, $m_ctx);
262    return $m_ctx;
263}
264
265# Helper to run the "finally" part of "_main".
266sub _main_finally {
267    my ($attrib_ref, $m_ctx) = @_;
268    $m_ctx->set_inherit_ctx_list([]);
269    $m_ctx->set_prev_ctx(undef);
270    $attrib_ref->{shared_util_of}{dest}->dest_done($m_ctx);
271    my $log_ctx = $attrib_ref->{util}->util_of_report()->del_ctx($m_ctx);
272    close($log_ctx->get_handle());
273}
274
275# Wrap "symlink".
276sub _symlink {
277    my ($source, $target) = @_;
278    if (-l $target && readlink($target) eq $source) {
279        return;
280    }
281    if (-e $target || -l $target) {
282        rmtree($target);
283    }
284    symlink($source, $target) || return $E->throw($E->DEST_CREATE, $target, $!);
285}
286
287# Wraps a piece of code with timer events.
288sub _timer_wrap {
289    my ($attrib_ref, $m_ctx, $code_ref, @names) = @_;
290    my @event_args = (
291        FCM::Context::Event->TIMER,
292        join(
293            q{ },
294            $attrib_ref->{name},
295            ($m_ctx->get_name() ? $m_ctx->get_name() : ()),
296            @names,
297        ),
298        time(),
299    );
300    $attrib_ref->{util}->event(@event_args);
301    my $timer = $attrib_ref->{util}->timer();
302    my $return = eval {wantarray() ? [$code_ref->()] : $code_ref->()};
303    my $e = $@;
304    $attrib_ref->{util}->event(@event_args, $timer->(), $e);
305    if ($e) {
306        die($e);
307    }
308    return (wantarray() ? @{$return} : $return);
309}
310
311# ------------------------------------------------------------------------------
3121;
313__END__
314
315=head1 NAME
316
317FCM::System::Make
318
319=head1 SYNOPSIS
320
321    use FCM::System::Make;
322    my $system = FCM::System::Make->new(\%attrib);
323    $system->(\%option);
324
325
326=head1 DESCRIPTION
327
328Invokes the FCM make system.
329
330=head1 METHODS
331
332=over 4
333
334=item $class->new(\%attrib)
335
336Creates and returns a new instance. The %attrib may contain the following:
337
338=over 4
339
340=item cfg_base
341
342The base name of the common (site/user) configuration file. (default="make.cfg")
343
344=item name
345
346The name of this sub-system. (default="make")
347
348=item shared_util_of
349
350A HASH to map the names to the classes of the named helper utilities for the
351make system and its sub-systems. (default = %FCM::System::Make::SHARED_UTIL_OF)
352
353=item subsystem_of
354
355A HASH to map the names to the classes of the subsystems. (default =
356%FCM::System::Make::SUBSYSTEM_OF)
357
358=item util
359
360An instance of L<FCM::Util|FCM::Util>.
361
362=back
363
364=item $system->(\%option)
365
366Invokes a make. The %option may contain the following:
367
368=over 4
369
370=item config-file
371
372The path to the configuration file. (default = $PWD/fcm-make.cfg)
373
374=item ignore-lock
375
376This flag can be used to ignore the lock file. The system creates a lock file in
377the destination to prevent another command from running in the same destination.
378If this flag is set, the system will continue even if it encounters a lock file
379in the destination. (default = false)
380
381=item jobs
382
383The number of (child) jobs that can be used to run parallel tasks.
384
385=item new
386
387A flag to tell the system to perform a new make. (default = false, i.e.
388incremental make)
389
390=back
391
392Throws L<FCM::System::Exception|FCM::System::Exception> on error.
393
394=back
395
396=head1 SUBSYSTEMS
397
398A subsystem of the make system should be a CODE-based class that implements a
399particular set of methods. (Some of these methods can be imported from
400L<FCM::System::Make::Share::Subsystem|FCM::System::Make::Share::Subsystem>.) The
401methods that should be implemented are:
402
403=over 4
404
405=item $subsystem_class->new(\%attrib)
406
407Creates a new instance of the subsystem. The make system passes the
408I<shared_util_of>, I<subsystem_of> and I<util> attributes to this method.
409
410=item $subsystem->config_parse($ctx,$entry,$label)
411
412Reads the settings of $entry into the $ctx. The $label is the configuration
413entry label in the context of the subsystem. (This is normally the
414$entry->get_label() but with the context ID prefix removed.). Returns true on
415success.
416
417=item $subsystem->config_parse_inherit_hook($ctx,$i_ctx)
418
419This method is called when the make inherits from an existing make. The $ctx is
420the current subsystem context, and the $i_ctx is the inherited subsystem
421context. This method allows the subsystem to make use of the inherited settings
422in the current context.
423
424=item $subsystem->config_unparse($ctx)
425
426Returns a list of L<FCM::Context::ConfigEntry|FCM::Context::ConfigEntry> to
427represent the settings of the $ctx.
428
429=item $subsystem->ctx($id_of_class,$id)
430
431Returns a new context for the subsystem. The $id_of_class is the ID of the
432subsystem class. The $id is the step ID of the context.
433
434=item $subsystem->config_parse_class_prop($entry,$label)
435
436Reads a configuration $entry into the subsystem default property. The $label is
437the label of the $entry, but with the prefix (the subsystem ID plus a dot)
438removed.
439
440=item $subsystem->main($m_ctx,$ctx)
441
442Invokes the subsystem. The $m_ctx is the current context of the make (as a
443blessed reference of L<FCM::Context::Make|FCM::Context::Make>). The $ctx is the
444context of the subsystem.
445
446=back
447
448=head1 COPYRIGHT
449
450Copyright (C) 2006-2021 British Crown (Met Office) & Contributors.
451
452=cut
Note: See TracBrowser for help on using the repository browser.