source: LMDZ6/branches/Amaury_dev/tools/fcm/lib/FCM/Util/Event.pm

Last change on this file was 5129, checked in by abarral, 4 months ago

Re-add removed by mistake fcm
File size: 46.3 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
22# ------------------------------------------------------------------------------
23package FCM::Util::Event;
24use base qw{FCM::Class::CODE};
25
26use Data::Dumper qw{Dumper};
27use FCM::Context::Event;
28use File::Basename qw{basename};
29use List::Util qw{first};
30use POSIX qw{strftime};
31use Scalar::Util qw{blessed};
32
33my $CTX = 'FCM::Context::Event';
34my $IS_MULTI_LINE = 1;
35
36# Event keys and their actions.
37my %ACTION_OF = (
38    $CTX->CM_ABORT                      => \&_event_cm_abort,
39    $CTX->CM_BRANCH_CREATE_SOURCE       => _func('cm_branch_create_source'),
40    $CTX->CM_BRANCH_LIST                => \&_event_cm_branch_list,
41    $CTX->CM_COMMIT_MESSAGE             => \&_event_cm_commit_message,
42    $CTX->CM_CONFLICT_TEXT              => _func('cm_conflict_text'),
43    $CTX->CM_CONFLICT_TEXT_SKIP         => \&_event_cm_conflict_text_skip,
44    $CTX->CM_CONFLICT_TREE              => _func('cm_conflict_tree'),
45    $CTX->CM_CONFLICT_TREE_SKIP         => \&_event_cm_conflict_tree_skip,
46    $CTX->CM_CONFLICT_TREE_TIME_WARN    => \&_event_cm_conflict_tree_time_warn,
47    $CTX->CM_CREATE_TARGET              => _func('cm_create_target'),
48    $CTX->CM_LOG_EDIT                   => _func('cm_log_edit'),
49    $CTX->CONFIG_OPEN                   => \&_event_config_open,
50    $CTX->CONFIG_ENTRY                  => \&_event_config_entry,
51    $CTX->CONFIG_VAR_UNDEF              => \&_event_config_var_undef,
52    $CTX->E                             => \&_event_e,
53    $CTX->EXPORT_ITEM_CREATE            => _func('export_item_create'),
54    $CTX->EXPORT_ITEM_DELETE            => _func('export_item_delete'),
55    $CTX->FCM_VERSION                   => _func('fcm_version'),
56    $CTX->KEYWORD_ENTRY                 => \&_event_keyword_entry,
57    $CTX->MAKE_BUILD_SHELL_OUT          => \&_event_make_build_shell_out,
58    $CTX->MAKE_BUILD_SOURCE_ANALYSE     => \&_event_make_build_source_analyse,
59    $CTX->MAKE_BUILD_SOURCE_SUMMARY     => _func('make_build_source_summary'),
60    $CTX->MAKE_BUILD_TARGET_DONE        => \&_event_make_build_target_done,
61    $CTX->MAKE_BUILD_TARGET_FAIL        => \&_event_make_build_target_fail,
62    $CTX->MAKE_BUILD_TARGET_FROM_NS     => \&_event_make_build_target_from_ns,
63    $CTX->MAKE_BUILD_TARGET_SELECT      => \&_event_make_build_target_select,
64    $CTX->MAKE_BUILD_TARGET_SELECT_TIMER=> _func('make_build_target_select_t'),
65    $CTX->MAKE_BUILD_TARGET_MISSING_DEP => \&_event_make_build_target_missing_dep,
66    $CTX->MAKE_BUILD_TARGET_STACK       => \&_event_make_build_target_stack,
67    $CTX->MAKE_BUILD_TARGET_SUMMARY     => _func('make_build_target_sum'),
68    $CTX->MAKE_BUILD_TARGET_TASK_SUMMARY=> _func('make_build_target_task_sum'),
69    $CTX->MAKE_BUILD_TARGETS_FAIL       => \&_event_make_build_targets_fail,
70    $CTX->MAKE_DEST                     => \&_event_make_dest,
71    $CTX->MAKE_EXTRACT_PROJECT_TREE     => \&_event_make_extract_project_tree,
72    $CTX->MAKE_EXTRACT_RUNNER_SUMMARY   => \&_event_make_extract_runner_summary,
73    $CTX->MAKE_EXTRACT_SYMLINK          => \&_event_make_extract_symlink,
74    $CTX->MAKE_EXTRACT_TARGET           => \&_event_make_extract_target,
75    $CTX->MAKE_EXTRACT_TARGET_SUMMARY   => \&_event_make_extract_target_summary,
76    $CTX->MAKE_MIRROR                   => \&_event_make_mirror,
77    $CTX->OUT                           => \&_event_out,
78    $CTX->SHELL                         => \&_event_shell,
79    $CTX->TASK_WORKERS                  => \&_event_task_workers,
80    $CTX->TIMER                         => \&_event_timer,
81);
82# Helper for "_event_e", list of exception classes and their formatters.
83our @E_FORMATTERS = (
84    ['FCM1::Cm::Exception'    , \&_format_e_cm            ],
85    ['FCM1::CLI::Exception'   , sub {$_[0]->get_message()}],
86    ['FCM::Class::Exception' , \&_format_e_class         ],
87    ['FCM::CLI::Exception'   , \&_format_e_cli           ],
88    ['FCM::System::Exception', \&_format_e_sys           ],
89    ['FCM::Util::Exception'  , \&_format_e_util          ],
90);
91# Error format strings for FCM1::Cm::Exception.
92our %E_CM_FORMAT_FOR = (
93    DIFF_PROJECTS     => "%s (target) and %s (source) are not related.\n",
94    INVALID_BRANCH    => "%s: not a valid URL of a standard FCM branch.\n",
95    INVALID_PROJECT   => "%s: not a valid URL of a standard FCM project.\n",
96    INVALID_TARGET    => "%s: not a valid working copy or URL.\n",
97    INVALID_URL       => "%s: not a valid URL.\n",
98    INVALID_WC        => "%s: not a valid working copy.\n",
99    MERGE_REV_INVALID => "%s: not a revision in the available merge list.\n",
100    MERGE_SELF        => "%s: cannot be merged to its own working copy: %s.\n",
101    MERGE_UNRELATED   => "%s: target and %s: source not directly related.\n",
102    MERGE_UNSAFE      => "%s: source contains changes outside the target"
103                         . " sub-directory. Please merge with a full tree.\n",
104    MKPATH            => "%s: cannot create directory.\n",
105    NOT_EXIST         => "%s: does not exist.\n",
106    PARENT_NOT_EXIST  => "%s: parent %s no longer exists.\n",
107    RMTREE            => "%s: cannot remove.\n",
108    ST_CONFLICT       => "File(s) in conflicts:\n%s",
109    ST_MISSING        => "File(s) missing:\n%s",
110    ST_OUT_OF_DATE    => "File(s) out of date:\n%s",
111    SWITCH_UNSAFE     => "%s: merge template exists."
112                         . " Please remove before retrying.\n",
113    WC_INVALID_BRANCH => "%s: not a working copy of a standard FCM branch.\n",
114    WC_URL_NOT_EXIST  => "%s: working copy URL does not exists at HEAD.\n",
115);
116# Helper for "_format_e_sys", formatters based on exception code.
117our %E_SYS_FORMATTER_FOR = (
118    BUILD_SOURCE     => _format_e_func('e_sys_build_source'),
119    BUILD_SOURCE_SYN => _format_e_func('e_sys_build_source_syn'),
120    BUILD_TARGET     => \&_format_e_sys_build_target,
121    BUILD_TARGET_BAD => _format_e_func('e_sys_build_target_bad', $IS_MULTI_LINE),
122    BUILD_TARGET_CYC => \&_format_e_sys_build_target_cyc,
123    BUILD_TARGET_DEP => \&_format_e_sys_build_target_dep,
124    BUILD_TARGET_DUP => \&_format_e_sys_build_target_dup,
125    CACHE_LOAD       => _format_e_func('e_sys_cache_load'),
126    CACHE_TYPE       => _format_e_func('e_sys_cache_type'),
127    CM_ALREADY_EXIST => _format_e_func('e_sys_cm_already_exist'),
128    CM_ARG           => _format_e_func('e_sys_cm_arg'),
129    CM_BRANCH_NAME   => _format_e_func('e_sys_cm_branch_name'),
130    CM_BRANCH_SOURCE => _format_e_func('e_sys_cm_branch_source'),
131    CM_CHECKOUT      => _format_e_func('e_sys_cm_checkout'),
132    CM_LOG_EDIT_NULL => _format_e_func('e_sys_cm_log_edit_null'),
133    CM_LOG_EDIT_DELIMITER => _format_e_func('e_sys_cm_log_edit_delimiter'),
134    CM_OPT_ARG       => _format_e_func('e_sys_cm_opt_arg'),
135    CM_PROJECT_NAME  => _format_e_func('e_sys_cm_project_name'),
136    CM_REPOSITORY    => _format_e_func('e_sys_cm_repository'),
137    CONFIG_CONFLICT  => _format_e_sys_config_func('conflict'),
138    CONFIG_INHERIT   => _format_e_sys_config_func('inherit'),
139    CONFIG_MODIFIER  => _format_e_sys_config_func('modifier'),
140    CONFIG_NS        => _format_e_sys_config_func('ns'),
141    CONFIG_NS_VALUE  => _format_e_sys_config_func('ns_value'),
142    CONFIG_UNKNOWN   => _format_e_sys_config_func('unknown'),
143    CONFIG_VALUE     => _format_e_sys_config_func('value'),
144    CONFIG_VERSION   => _format_e_sys_config_func('version'),
145    COPY             => _format_e_func('e_sys_copy'),
146    DEST_CLEAN       => _format_e_func('e_sys_dest_clean'),
147    DEST_CREATE      => _format_e_func('e_sys_dest_create'),
148    DEST_LOCK        => _format_e_func('e_sys_dest_lock'),
149    DEST_LOCKED      => _format_e_func('e_sys_dest_locked'),
150    EXPORT_ITEMS_SRC => _format_e_func('e_sys_export_items_src'),
151    EXTRACT_LOC_BASE => _format_e_func('e_sys_extract_loc_base'),
152    EXTRACT_MERGE    => \&_format_e_sys_extract_merge,
153    EXTRACT_NS       => _format_e_func('e_sys_extract_ns', $IS_MULTI_LINE),
154    MIRROR           => \&_format_e_sys_mirror,
155    MIRROR_NULL      => _format_e_func('e_sys_mirror_null'),
156    MIRROR_SOURCE    => _format_e_func('e_sys_mirror_source', $IS_MULTI_LINE),
157    MIRROR_TARGET    => _format_e_func('e_sys_mirror_target'),
158    MAKE             => _format_e_func('e_sys_make'),
159    MAKE_ARG         => \&_format_e_sys_make_arg,
160    MAKE_CFG         => _format_e_func('e_sys_make_cfg'),
161    MAKE_CFG_FILE    => _format_e_func('e_sys_make_cfg_file'),
162    MAKE_PROP_NS     => \&_format_e_sys_make_prop_ns,
163    MAKE_PROP_VALUE  => \&_format_e_sys_make_prop_value,
164    SHELL            => \&_format_e_sys_shell,
165);
166# Helper for "_format_e_util", formatters based on exception code.
167our %E_UTIL_FORMATTER_FOR = (
168    CLASS_LOADER         => _format_e_func('e_util_class_loader'),
169    CONFIG_CONT_EOF      => _format_e_util_config_func('eof'),
170    CONFIG_CYCLIC        => _format_e_util_config_stack_func('cyclic'),
171    CONFIG_LOAD          => _format_e_util_config_stack_func('load'),
172    CONFIG_SYNTAX        => _format_e_util_config_func('syntax'),
173    CONFIG_USAGE         => _format_e_util_config_func('usage'),
174    CONFIG_VAR_UNDEF     => _format_e_util_config_func('var_undef'),
175    IO                   => _format_e_func('e_util_io'),
176    LOCATOR_AS_INVARIANT => _format_e_util_locator_func(''),
177    LOCATOR_BROWSER_URL  => _format_e_util_locator_func('_browser_url'),
178    LOCATOR_FIND         => _format_e_util_locator_func(''),
179    LOCATOR_KEYWORD_LOC  => _format_e_util_locator_func('_keyword_loc'),
180    LOCATOR_KEYWORD_REV  => _format_e_util_locator_func('_keyword_rev'),
181    LOCATOR_READER       => _format_e_util_locator_func('_reader'),
182    LOCATOR_TYPE         => _format_e_util_locator_func('_type'),
183    SHELL_OPEN3          => _format_e_util_shell_func('_open3'),
184    SHELL_OS             => _format_e_util_shell_func('_os'),
185    SHELL_SIGNAL         => _format_e_util_shell_func('_signal'),
186    SHELL_WHICH          => _format_e_util_shell_func('_which'),
187);
188# Alias
189our $R;
190# Named diagnostic strings
191our %S = (
192    # ERROR DIAGNOSTICS
193    e_class                      => '%s: %s => %s: internal error at %s:%d',
194    e_cli_app                    => '%s: unknown command,'
195                                    . ' type \'%s help\' for help',
196    e_cli_opt                    => '%s: incorrect usage,'
197                                    . ' type \'%s help %1$s\' for help',
198    e_sys_build_source           => '%s: source does not exist',
199    e_sys_build_source_syn       => '%s(%d): syntax error',
200    e_sys_build_target           => '%s: target not found after an update:',
201    e_sys_build_target_1         => '%s: expect target file',
202    e_sys_build_target_bad       => '%s: don\'t know how to build specified'
203                                    . ' target',
204    e_sys_build_target_cyclic    => '%s: target depends on itself',
205    e_sys_build_target_dep       => '%s: bad or missing dependency (type=%s)',
206    e_sys_build_target_dup       => '%s: same target from [%s]',
207    e_sys_build_target_stack     => '    required by: %s',
208    e_sys_cache_load             => '%s: cannot retrieve cache',
209    e_sys_cache_type             => '%s: unexpected cache type',
210    e_sys_cm_already_exist       => '%s: already exists',
211    e_sys_cm_arg                 => '%s: bad argument',
212    e_sys_cm_branch_name         => '%s: invalid branch name',
213    e_sys_cm_branch_source       => '%s: invalid branch source',
214    e_sys_cm_checkout            => '%s: is already a working copy of %s',
215    e_sys_cm_log_edit_delimiter  => '%sthe above log delimiter is altered',
216    e_sys_cm_log_edit_null       => 'log message is empty',
217    e_sys_cm_opt_arg             => '%s=%s: bad option argument',
218    e_sys_cm_project_name        => '%s: invalid project name',
219    e_sys_cm_repository          => '%s: invalid repository',
220    e_sys_config_conflict        => '%s: cannot modify, value is inherited',
221    e_sys_config_inherit         => '%s: cannot inherit from an incomplete make',
222    e_sys_config_modifier        => '%s: incorrect modifier in declaration',
223    e_sys_config_ns              => '%s: incorrect name-space declaration',
224    e_sys_config_ns_value        => '%s: mismatch between name-space and value',
225    e_sys_config_unknown         => '%s: unknown declaration',
226    e_sys_config_value           => '%s: incorrect value in declaration',
227    e_sys_config_version         => '%s: requested version mismatch',
228    e_sys_copy                   => '%s -> %s: copy failed',
229    e_sys_dest_clean             => '%s: cannot remove',
230    e_sys_dest_create            => '%s: cannot create',
231    e_sys_dest_locked            => '%s: lock exists at the destination',
232    e_sys_export_items_src       => 'source location not specified',
233    e_sys_extract_loc_base       => '%s: cannot determine base location',
234    e_sys_extract_merge          => '%s: merge results in conflict',
235    e_sys_extract_merge_output   => '    merge output: %s',
236    e_sys_extract_merge_source   => '    source from location %2d: %s',
237    e_sys_extract_merge_source_0 => '(none)',
238    e_sys_extract_merge_source_x => '!!! source from location %2d: %s',
239    e_sys_extract_ns             => '%s: name-spaces declared but not used',
240    e_sys_mirror                 => '%s <- %s: mirror failed',
241    e_sys_mirror_null            => 'mirror target not specified',
242    e_sys_mirror_source          => '%s: cannot mirror this step',
243    e_sys_mirror_target          => '%s: cannot create mirror target',
244    e_sys_make                   => '%s: step is not implemented',
245    e_sys_make_arg               => 'arg %d (%s): invalid config declaration',
246    e_sys_make_arg_more          => 'did you mean "%s"?',
247    e_sys_make_cfg               => 'no configuration specified or found',
248    e_sys_make_cfg_file          => '%s: no such configuration file',
249    e_sys_make_prop_ns           => '%s.prop{%s}[%s] = %s: bad name-space',
250    e_sys_make_prop_value        => '%s.prop{%s}[%s] = %s: bad value',
251    e_sys_shell                  => '%s # rc=%d',
252    e_unknown                    => 'command failed',
253    e_util_class_loader          => '%s: required package cannot be loaded',
254    e_util_config                => '%s:%d: %s',
255    e_util_config_eof            => 'continuation at eof',
256    e_util_config_syntax         => 'syntax error',
257    e_util_config_usage          => 'incorrect usage',
258    e_util_config_var_undef      => 'reference to undefined variable',
259    e_util_config_stack_cyclic   => '%s: cannot load config file,'
260                                    . ' cyclic dependency',
261    e_util_config_stack_load     => '%s: cannot load config file',
262    e_util_io                    => '%s: I/O error',
263    e_util_locator               => '%s: not found',
264    e_util_locator_browser_url   => '%s: cannot determine browser URL',
265    e_util_locator_keyword_loc   => '%s: location keyword not defined',
266    e_util_locator_keyword_rev   => '%s: revision keyword not defined',
267    e_util_locator_reader        => '%s: cannot be read',
268    e_util_locator_type          => '%s: unsupported type of location',
269    e_util_shell_open3           => '%s: command failed to invoke',
270    e_util_shell_os              => '%s: command failed due to OS error',
271    e_util_shell_signal          => '%s: command received a signal',
272    e_util_shell_which           => '%s: command not found',
273
274    # NORMAL DIAGNOSTICS
275    cm_abort_null                => 'command will result in no change',
276    cm_abort_user                => 'by user',
277    cm_branch_create_source      => 'Source: %s (%d)',
278    cm_branch_list               => '%s: %d match(es)',
279    cm_commit_message            => 'Change summary:' . "\n"
280                                    . '-' x 80 . "\n" . '%s'
281                                    . '-' x 80 . "\n"
282                                    . 'Commit message is as follows:' . "\n"
283                                    . '-' x 80 . "\n" . '%s%s'
284                                    . '-' x 80,
285    cm_conflict_text             => '%s: in text conflict.',
286    cm_conflict_text_skip        => '%s: skipped binary file in text conflict.',
287    cm_conflict_tree             => '%s: in tree conflict.',
288    cm_conflict_tree_skip        => '%s: skipped unhandled tree conflict.',
289    cm_conflict_tree_time_warn   => '%s: looking for a rename operation,'
290                                    . ' please wait...',
291    cm_create_target             => 'Created: %s',
292    cm_log_edit                  => '%s: starting commit message editor...',
293    config_open                  => 'config-file=%s%s',
294    config_var_undef             => '%s:%d: %s: variable not defined',
295    event                        => '%s: event raised',
296    export_item_create           => 'A %s@%s -> %s',
297    export_item_delete           => 'D %s@%s -> %s',
298    fcm_version                  => '%s',
299    keyword_loc                  => 'location[%s] = %s',
300    keyword_loc_primary          => 'location{primary}[%s] = %s',
301    keyword_rev                  => 'revision[%s:%s] = %s',
302    make_build_shell_out_1       => '[>>&1] ',
303    make_build_shell_out_2       => '[>>&2] ',
304    make_build_source_analyse    => 'analyse %4.1f %s',
305    make_build_source_analyse_1  => '             -> (%9s) %s',
306    make_build_source_summary    => 'sources: total=%d, analysed=%d,'
307                                    . ' elapsed-time=%.1fs, total-time=%.1fs',
308    make_build_target_done_0     => '%-9s ---- %s %-20s <- %s',
309    make_build_target_done_1     => '%-9s %4.1f %s %-20s <- %s',
310    make_build_target_from_ns    => 'source->target %s -> (%s) %s/ %s',
311    make_build_target_select     => 'required-target: %-9s %-7s %s',
312    make_build_target_select_t   => 'target-tree-analysis: elapsed-time=%.1fs',
313    make_build_target_stack      => 'target %s%s%s',
314    make_build_target_stack_more => ' (n-deps=%d)',
315    make_build_target_missing_dep=> '%-30s: ignore-missing-dep: (%3$9s) %2$s',
316    make_build_target_sum        => 'TOTAL     targets:'
317                                    . ' modified=%d, unchanged=%d, failed=%d,'
318                                    . ' elapsed-time=%.1fs',
319    make_build_target_task_sum   => '%-9s targets:'
320                                    . ' modified=%d, unchanged=%d, failed=%d,'
321                                    . ' total-time=%.1fs',
322    make_build_targets_fail_0    => '! %-20s: depends on failed target: %s',
323    make_build_targets_fail_1    => '! %-20s: update task failed',
324    make_description             => 'description=%s',
325    make_dest                    => 'dest=%s',
326    make_dest_use                => 'use=%s',
327    make_extract_project_tree    => 'location %5s:%2d: %s%s',
328    make_extract_project_tree_1  => ' (%s)',
329    make_extract_runner_summary  => '%s: n-tasks=%d,'
330                                    . ' elapsed-time=%.1fs, total-time=%.1fs',
331    make_extract_target          => '%s%s %5s:%-6s %s',
332    make_extract_target_base_yes => '0',
333    make_extract_target_base_no  => '-',
334    make_extract_symlink         => 'symlink ignored: %s',
335    make_extract_target_summary_d=> '  dest: %4d [%1s %s]',
336    make_extract_target_summary_s=> 'source: %4d [%1s %s]',
337    make_mirror                  => '%s <- %s',
338    make_mode                    => 'mode=%s',
339    make_mode_new                => 'new',
340    make_mode_incr               => 'incremental',
341    shell                        => 'shell(%d %4.1f) %s',
342    task_workers_destroy         => '%s worker processes destroyed',
343    task_workers_init            => '%s worker processes started',
344    timer_done                   => '%-20s# %.1fs',
345    timer_init                   => '%-20s# %s',
346);
347# Symbols/Descriptions for a make extract target status.
348my %MAKE_EXTRACT_TARGET_SYM_OF = (
349    ST_ADDED     => ['A', 'added'                        ],
350    ST_DELETED   => ['D', 'deleted'                      ],
351    ST_MODIFIED  => ['M', 'modified'                     ],
352    ST_O_ADDED   => ['a', 'added, overriding inherited'  ],
353    ST_O_DELETED => ['d', 'deleted, overriding inherited'],
354    ST_UNCHANGED => ['U', 'unchanged'                    ],
355    ST_UNKNOWN   => ['?', 'unknown'                      ],
356);
357# Symbols/Descriptions for a make source status.
358my %MAKE_EXTRACT_SOURCE_SYM_OF = (
359    ST_ADDED     => ['A', 'added by a diff source tree'     ],
360    ST_DELETED   => ['D', 'deleted by a diff source tree'   ],
361    ST_MERGED    => ['G', 'merged from 2+ diff source trees'],
362    ST_MODIFIED  => ['M', 'modified by a diff source tree'  ],
363    ST_UNCHANGED => ['U', 'from base'                       ],
364    ST_UNKNOWN   => ['?', 'unknown'                         ],
365);
366
367# Creates the class.
368__PACKAGE__->class({util => '&'}, {action_of => {main => \&_main}});
369
370sub _main {
371    my ($attrib_ref, $event) = @_;
372    local($R) = $attrib_ref->{util}->util_of_report();
373    if (!exists($ACTION_OF{$event->get_code()})) {
374        return $R->report(
375            {level => $R->HIGH}, sprintf($S{event}, $event->get_code()),
376        );
377    }
378    $ACTION_OF{$event->get_code()}->(@{$event->get_args()});
379}
380
381# Formats a stack of configuration files.
382sub _format_config_stack {
383    my ($config_stack_ref) = @_;
384    my @config_stack = @{$config_stack_ref};
385    my $indent_char = q{};
386    my $return = q{};
387    my $i = 0;
388    for my $item (@config_stack) {
389        my ($locator, $line) = @{$item};
390        my $indent = q{ - } x $i++;
391        $return .= sprintf(
392            $S{'config_open'} . "\n",
393            $indent, ($locator->get_value() . ($line ? ':' . $line : q{})),
394        );
395    }
396    return $return;
397}
398
399# Formats a CM exception.
400sub _format_e_cm {
401    my ($e) = @_;
402    sprintf($E_CM_FORMAT_FOR{$e->get_code()}, $e->get_targets());
403}
404
405# Formats a class exception.
406sub _format_e_class {
407    my ($e) = @_;
408    sprintf(
409        $S{e_class},
410        $e->get_package(),
411        $e->get_key(),
412        (defined($e->get_value()) ? $e->get_value() : 'undef'),
413        @{$e->get_caller()}[1, 2],
414    );
415}
416
417# Formats a CLI exception.
418sub _format_e_cli {
419    my ($e) = @_;
420    my $format
421        = $e->get_code() eq $e->APP ? $S{e_cli_app}
422        :                             $S{e_cli_opt}
423        ;
424    sprintf($format, $e->get_ctx()->[0], basename($0));
425}
426
427# Formats a system exception.
428sub _format_e_sys {
429    my ($e) = @_;
430    if (exists($E_SYS_FORMATTER_FOR{$e->get_code()})) {
431        return $E_SYS_FORMATTER_FOR{$e->get_code()}->($e);
432    }
433    $e;
434}
435
436# Formats a system exception - CONFIG_*.
437sub _format_e_sys_config_func {
438    my ($suffix) = @_;
439    my $key = 'e_sys_config_' . $suffix;
440    sub {
441        my ($e) = @_;
442        my @ctx_list
443            = ref($e->get_ctx()) eq 'ARRAY' ? @{$e->get_ctx()}
444            :                                 ($e->get_ctx())
445            ;
446        map {(
447            sprintf($S{$key}, $_->as_string()),
448            _format_config_stack($_->get_stack()),
449        )} @ctx_list;
450    }
451}
452
453# Formats a system exception - BUILD_TARGET.
454sub _format_e_sys_build_target {
455    my ($e) = @_;
456    my $ctx = $e->get_ctx();
457    (   sprintf($S{e_sys_build_target}, $ctx->get_key()),
458        sprintf($S{e_sys_build_target_1}, $ctx->get_path()),
459    );
460}
461
462# Formats a system exception - BUILD_TARGET_CYC.
463sub _format_e_sys_build_target_cyc {
464    my ($e) = @_;
465    my @messages;
466    while (my ($key, $hash_ref) = each(%{$e->get_ctx()})) {
467        my ($head, @stack) = reverse(@{$hash_ref->{'keys'}});
468        push(@messages, sprintf($S{e_sys_build_target_cyclic}, $head));
469        push(@messages, map {sprintf($S{e_sys_build_target_stack}, $_)} @stack);
470    }
471    @messages;
472}
473
474# Formats a system exception - BUILD_TARGET_DEP.
475sub _format_e_sys_build_target_dep {
476    my ($e) = @_;
477    my @messages;
478    while (my ($key, $hash_ref) = each(%{$e->get_ctx()})) {
479        my ($head, @stack) = reverse(@{$hash_ref->{'keys'}});
480        for (@{$hash_ref->{'values'}}) { # [$dep_key, $dep_type]
481            my ($dep_name, $dep_type, $dep_remark) = @{$_};
482            if ($dep_remark) {
483                $dep_type = $dep_remark . '.' . $dep_type;
484            }
485            push(
486                @messages,
487                sprintf($S{e_sys_build_target_dep}, $dep_name, $dep_type),
488            );
489        }
490        push(@messages, map {sprintf($S{e_sys_build_target_stack}, $_)} @stack);
491    }
492    @messages;
493}
494
495# Formats a system exception - BUILD_TARGET_DUP.
496sub _format_e_sys_build_target_dup {
497    my ($e) = @_;
498    my @messages;
499    while (my ($key, $hash_ref) = each(%{$e->get_ctx()})) {
500        my ($head, @stack) = reverse(@{$hash_ref->{'keys'}});
501        my @ns_list = @{$hash_ref->{'values'}};
502        my $ns = _format_shell_words({'delimiter' => q{, }}, sort(@ns_list));
503        push(@messages, sprintf($S{e_sys_build_target_dup}, $key, $ns));
504        push(@messages, map {sprintf($S{e_sys_build_target_stack}, $_)} @stack);
505    }
506    @messages;
507}
508
509# Formats a system exception - EXTRACT_MERGE.
510sub _format_e_sys_extract_merge {
511    my ($e) = @_;
512    my $target = $e->get_ctx()->{'target'};
513    my $source0 = $target->get_source_of()->{0};
514    my $location_of_0 = $S{e_sys_extract_merge_source_0};
515    if ($source0->get_locator()) {
516        $location_of_0 = $source0->get_locator()->get_value();
517    }
518    my $key = $e->get_ctx()->{'key'};
519    my $location_of_key
520        = $target->get_source_of()->{$key}->get_locator()->get_value();
521    (   sprintf($S{e_sys_extract_merge}, $target->get_ns()),
522        sprintf($S{e_sys_extract_merge_output}, $e->get_ctx()->{'output'}),
523        sprintf($S{e_sys_extract_merge_source}, 0, $location_of_0),
524        (   map {sprintf(
525                $S{e_sys_extract_merge_source},
526                $_,
527                $target->get_source_of()->{$_}->get_locator()->get_value(),
528            )} @{$e->get_ctx()->{'keys_done'}}
529        ),
530        sprintf($S{e_sys_extract_merge_source_x}, $key, $location_of_key),
531        (   map {sprintf(
532                $S{e_sys_extract_merge_source},
533                $_,
534                $target->get_source_of()->{$_}->get_locator()->get_value(),
535            )} @{$e->get_ctx()->{'keys_left'}}
536        ),
537    );
538}
539
540# Formats a system exception - MIRROR.
541sub _format_e_sys_mirror {
542    my ($e) = @_;
543    my ($target, @sources) = @{$e->get_ctx()};
544    sprintf($S{e_sys_mirror}, $target, _format_shell_words(@sources));
545}
546
547# Formats a system exception - MAKE_ARG
548sub _format_e_sys_make_arg {
549    my ($e) = @_;
550    my @return;
551    for (@{$e->get_ctx()}) {
552        my ($arg_index, $arg_value) = @{$_};
553        push(@return, sprintf($S{e_sys_make_arg}, $arg_index, $arg_value));
554        my $advice
555            = $arg_value =~ qr{\.cfg\z}msx ? '-f ' . $arg_value
556            : $arg_value eq '0'            ? '-q'
557            : $arg_value eq '2'            ? '-v'
558            : $arg_value eq '3'            ? '-v -v'
559            :                                undef;
560        if (defined($advice)) {
561            push(@return, sprintf($S{e_sys_make_arg_more}, $advice));
562        }
563    }
564    return @return;
565}
566
567# Formats a system exception - MAKE_PROP_NS
568sub _format_e_sys_make_prop_ns {
569    my ($e) = @_;
570    map {sprintf($S{e_sys_make_prop_ns}, @{$_})} @{$e->get_ctx()};
571}
572
573# Formats a system exception - MAKE_PROP_VALUE
574sub _format_e_sys_make_prop_value {
575    my ($e) = @_;
576    map {sprintf($S{e_sys_make_prop_value}, @{$_})} @{$e->get_ctx()};
577}
578
579# Formats a system exception - SHELL.
580sub _format_e_sys_shell {
581    my ($e) = @_;
582    my $command = _format_shell_words(@{$e->get_ctx()->{command_list}});
583    my %value_of = (out => q{}, rc => '?', %{$e->get_ctx()});
584    return (
585        #(map {sprintf($S{e_sys_shell_err}, $_)} split("\n", $value_of{err})),
586        #(map {sprintf($S{e_sys_shell_out}, $_)} split("\n", $value_of{out})),
587        sprintf($S{e_sys_shell}, $command, $value_of{rc}),
588    );
589}
590
591# Formats a util exception.
592sub _format_e_util {
593    my ($e) = @_;
594    if (exists($E_UTIL_FORMATTER_FOR{$e->get_code()})) {
595        return $E_UTIL_FORMATTER_FOR{$e->get_code()}->($e);
596    }
597    $e;
598}
599
600# Returns a CODE to format a util config-reader exception.
601sub _format_e_util_config_func {
602    my ($id) = @_;
603    sub {
604        my ($e) = @_;
605        (   sprintf(
606                $S{'e_util_config'},
607                $e->get_ctx()->get_stack()->[-1][0]->get_value(),
608                $e->get_ctx()->get_stack()->[-1][1],
609                $S{'e_util_config_' . $id},
610            ),
611            $e->get_ctx()->as_string(),
612        );
613    };
614}
615
616# Returns a CODE to format a util config-reader exception where the ctx is the
617# locator stack.
618sub _format_e_util_config_stack_func {
619    my ($id) = @_;
620    sub {
621        my ($e) = @_;
622        my @return = (
623            _format_config_stack($e->get_ctx()),
624            sprintf(
625                $S{'e_util_config_stack_' . $id},
626                $e->get_ctx()->[-1][0]->get_value(),
627            ),
628        );
629        @return;
630    };
631}
632
633# Formats a locator exception.
634sub _format_e_util_locator_func {
635    my ($id) = @_;
636    sub {sprintf($S{'e_util_locator' . $id}, $_[0]->get_ctx()->get_value())};
637}
638
639# Formats a shell exception.
640sub _format_e_util_shell_func {
641    my ($id) = @_;
642    sub {
643        sprintf(
644            $S{'e_util_shell' . $id},
645            _format_shell_words(@{$_[0]->get_ctx()})
646        );
647    };
648}
649
650# Returns a CODE to format a exception context in a single/multi line.
651sub _format_e_func {
652    my ($id, $is_multi_line) = @_;
653    sub {
654        my ($e) = @_;
655        my @args;
656        if (defined($e->get_ctx())) {
657            @args = (ref($e->get_ctx()) || ref($e->get_ctx()) eq 'ARRAY')
658                ? @{$e->get_ctx()} : $e->get_ctx();
659        }
660        $is_multi_line
661            ? (map {sprintf($S{$id}, $_)} @args) : (sprintf($S{$id}, @args));
662    };
663}
664
665# Formats a simple reference.
666sub _format_ref {
667    my ($hash_ref) = @_;
668    local($Data::Dumper::Terse) = 1;
669    local($Data::Dumper::Indent) = 0;
670    Dumper($hash_ref);
671}
672
673# Formats words into a string suitable for used in a shell command.
674sub _format_shell_words {
675    my %option = ('delimiter' => q{ });
676    if (@_ && ref($_[0]) && ref($_[0]) eq 'HASH') {
677        %option = (%option, %{$_[0]});
678        shift();
679    }
680    my (@words) = @_;
681    join(
682        $option{'delimiter'},
683        map {my $s = $_; $s =~ s{(['"\s])}{\\$1}gmsx; $s} @words,
684    );
685}
686
687# Notification on abort of a CM command.
688sub _event_cm_abort {
689    my ($id) = @_;
690    $R->report(
691        {level => $R->QUIET, prefix => $R->PREFIX_QUIT, type => $R->TYPE_ERR},
692        $S{'cm_abort_' . $id},
693    );
694}
695
696# Notification on a project branch listing.
697sub _event_cm_branch_list {
698    my ($project, @branches) = @_;
699    $R->report(sprintf($S{'cm_branch_list'}, $project, scalar(@branches)));
700    for my $branch (@branches) {
701        $R->report({level => $R->QUIET, prefix => $R->PREFIX_NULL}, $branch);
702    }
703}
704
705# Notification on a log message to be used by a commit.
706sub _event_cm_commit_message {
707    my ($ctx) = @_;
708    $R->report(
709        {prefix => $R->PREFIX_NULL},
710        sprintf(
711            $S{'cm_commit_message'},
712            $ctx->get_info_part(), $ctx->get_user_part(), $ctx->get_auto_part(),
713        ),
714    );
715}
716
717# Notification on a skipped file in text conflict.
718sub _event_cm_conflict_text_skip {
719    my ($ctx) = @_;
720    $R->report({type => $R->TYPE_ERR}, sprintf($S{'cm_conflict_text_skip'}, $ctx));
721}
722
723# Notification for an unhandled type of tree conflict.
724sub _event_cm_conflict_tree_skip {
725    my ($ctx) = @_;
726    $R->report({type => $R->TYPE_ERR}, sprintf($S{'cm_conflict_tree_skip'}, $ctx));
727}
728
729# Warning that the tree conflict operation search may take some time.
730sub _event_cm_conflict_tree_time_warn {
731    my ($ctx) = @_;
732    $R->report({type => $R->TYPE_ERR}, sprintf($S{'cm_conflict_tree_time_warn'}, $ctx));
733}
734
735# Notification when a config entry is found.
736sub _event_config_entry {
737    my ($entry, $in_fcm1) = @_;
738    $R->report(
739        {level => $R->QUIET, prefix => $R->PREFIX_NULL},
740        $entry->as_string($in_fcm1),
741    );
742}
743
744# Notification for a configuration file open.
745sub _event_config_open {
746    my ($config_stack_ref, $level) = @_;
747    $R->report(
748        {level => (defined($level) ? $level : $R->DEBUG)},
749        sub {
750            my $value = $config_stack_ref->[-1][0]->get_value();
751            my $indent = q{ - } x (scalar(@{$config_stack_ref}) - 1);
752            sprintf($S{config_open}, $indent, $value);
753        },
754    );
755}
756
757# Notification when a config variable is undefined.
758sub _event_config_var_undef {
759    my ($entry, $symbol) = @_;
760    $R->report(
761        {type => $R->TYPE_ERR},
762        sprintf(
763            $S{'config_var_undef'},
764            $entry->get_stack()->[-1][0]->get_value(),
765            $entry->get_stack()->[-1][1],
766            $symbol,
767        ),
768    );
769}
770
771# Notification for an exception.
772sub _event_e {
773    my ($exception) = @_;
774    my @e_stack = ($exception);
775    while ( blessed($e_stack[-1])
776        &&  $e_stack[-1]->can('get_exception')
777        &&  (my $e = $e_stack[-1]->get_exception())
778    ) {
779        push(@e_stack, $e);
780    }
781    while (my $e = shift(@e_stack)) {
782        my $formatter;
783        if (blessed($e)) {
784            my $item = first {$e->isa($_->[0])} @E_FORMATTERS;
785            if ($item) {
786                $formatter = $item->[1];
787            }
788            if (!$formatter && $e->can('as_string')) {
789                $formatter = sub {$e->as_string()};
790            }
791        }
792        elsif (ref($e)) {
793            $formatter = \&_format_ref;
794        }
795        elsif ($e eq "\n") {
796            chomp($e);
797        }
798        $R->report(
799            {level => $R->FAIL, type => $R->TYPE_ERR},
800            (defined($formatter) ? $formatter->($e) : $e),
801        );
802    }
803    1;
804}
805
806# Notification when a keyword entry is found.
807sub _event_keyword_entry {
808    my ($entry) = @_;
809    if ($entry->is_implied()) {
810        return;
811    }
812    my @implied_entry_list
813        = values(%{$entry->get_ctx_of_implied()->get_entry_by_key()});
814    if (@implied_entry_list) {
815        $R->report(
816            {level => $R->QUIET, prefix => $R->PREFIX_NULL},
817            sprintf(
818                $S{keyword_loc_primary},
819                $entry->get_key(),
820                $entry->get_value(),
821            ),
822        );
823        for my $implied_entry (
824            sort {$a->get_key() cmp $b->get_key()} @implied_entry_list
825        ) {
826            $R->report(
827                {level => $R->MEDIUM, prefix => $R->PREFIX_NULL},
828                sprintf(
829                    $S{keyword_loc},
830                    $implied_entry->get_key(),
831                    $implied_entry->get_value(),
832                ),
833            );
834        }
835    }
836    else {
837        $R->report(
838            {level => $R->QUIET, prefix => $R->PREFIX_NULL},
839            sprintf($S{keyword_loc}, $entry->get_key(), $entry->get_value()),
840        );
841    }
842    my @revision_entry_list
843        = values(%{$entry->get_ctx_of_rev()->get_entry_by_key()});
844    for my $revision_entry (
845        sort {$a->get_key() cmp $b->get_key()} @revision_entry_list
846    ) {
847        $R->report(
848            {level => $R->QUIET, prefix => $R->PREFIX_NULL},
849            sprintf(
850                $S{keyword_rev},
851                $entry->get_key(),
852                $revision_entry->get_key(),
853                $revision_entry->get_value(),
854            ),
855        );
856    }
857    1;
858}
859
860# Notification of the output from a command.
861sub _event_out {
862    my ($out, $err) = @_;
863    my %option = (delimiter => q{}, prefix => $R->PREFIX_NULL);
864    if ($err) {
865        $R->report({level => $R->WARN, type => $R->TYPE_ERR, %option}, $err);
866    }
867    if ($out) {
868        $R->report({level => $R->QUIET, %option}, $out);
869    }
870}
871
872# Notification of the output from a command invoked by make/build.
873sub _event_make_build_shell_out {
874    my ($out, $err) = @_;
875    if ($err) {
876        $R->report(
877            {   level => $R->HIGH,
878                prefix => $S{'make_build_shell_out_2'},
879                type => $R->TYPE_ERR,
880            },
881            $err,
882        );
883    }
884    if ($out) {
885        $R->report(
886            {level => $R->HIGH, prefix => $S{'make_build_shell_out_1'}},
887            $out,
888        );
889    }
890}
891
892# Notification when a make destination is being set up.
893sub _event_make_dest {
894    my ($m_ctx, $authority) = @_;
895    if ($m_ctx->get_description()) {
896        $R->report(sprintf($S{make_description}, $m_ctx->get_description()));
897    }
898    $R->report(sprintf($S{make_dest}, $authority . ':' . $m_ctx->get_dest()));
899    $R->report(sprintf(
900        $S{make_mode},
901        $S{'make_mode_' . ($m_ctx->get_prev_ctx() ? 'incr' : 'new')},
902    ));
903    for my $i_ctx (@{$m_ctx->get_inherit_ctx_list()}) {
904        $R->report(sprintf($S{make_dest_use}, $i_ctx->get_dest()));
905    }
906}
907
908# Notification when performing a mirroring.
909sub _event_make_mirror {
910    my ($target, @sources) = @_;
911    $R->report(sprintf($S{make_mirror}, $target, _format_shell_words(@sources)));
912}
913
914# Notification when the multi-thread task runner initiates its workers.
915sub _event_task_workers {
916    my ($id, $n_workers) = @_;
917    my $key = 'task_workers_' . $id;
918    if (exists($S{$key})) {
919        $R->report({level => $R->HIGH}, sprintf($S{$key}, $n_workers));
920    }
921}
922
923# Notification when invoking a shell command.
924sub _event_shell {
925    my ($names_ref, $rc, $elapsed) = @_;
926    my $name = _format_shell_words(@{$names_ref});
927    my $message = sprintf($S{shell}, $rc, $elapsed, $name);
928    $R->report({level => $R->HIGH}, $message);
929}
930
931# Notification when a timer starts/ends.
932sub _event_timer {
933    my ($name, $start, $elapsed, $failed) = @_;
934    my $message;
935    if (defined($elapsed)) {
936        $message = sprintf($S{timer_done}, $name, $elapsed);
937    }
938    else {
939        my $format = '%Y-%m-%dT%H:%M:%SZ';
940        $message = sprintf(
941            $S{timer_init}, $name, strftime($format, gmtime($start)));
942    }
943    my $prefix
944        = $failed           ? $R->PREFIX_FAIL
945        : defined($elapsed) ? $R->PREFIX_DONE
946        :                     $R->PREFIX_INIT
947        ;
948    $R->report({prefix => $prefix}, $message);
949}
950
951# Notification when make-build analyse a source.
952sub _event_make_build_source_analyse {
953    my ($source, $elapse) = @_;
954    $R->report(
955        {level => $R->MEDIUM},
956        sprintf($S{make_build_source_analyse}, $elapse, $source->get_ns()),
957    );
958    for my $dep (@{$source->get_deps()}) {
959        $R->report(
960            {level => $R->HIGH},
961            sprintf($S{make_build_source_analyse_1}, reverse(@{$dep})),
962        );
963    }
964}
965
966# Notification when make-build has updated or does not need to update a target.
967sub _event_make_build_target_done {
968    my ($target, $elapsed_time) = @_;
969    my $tmpl = defined($elapsed_time)
970        ? $S{make_build_target_done_1} : $S{make_build_target_done_0};
971    $R->report(
972        {level => $R->MEDIUM},
973        sprintf(
974            $tmpl,
975            $target->get_task(),
976            (defined($elapsed_time) ? ($elapsed_time) : ()),
977            $MAKE_EXTRACT_TARGET_SYM_OF{$target->get_status()}[0],
978            $target->get_key(),
979            $target->get_ns(),
980        ),
981    );
982}
983
984# Notification when make-build a target fails to update or is failed by
985# dependencies.
986sub _event_make_build_target_fail {
987    my ($target, $elapsed_time) = @_;
988    my $tmpl = defined($elapsed_time)
989        ? $S{make_build_target_done_1} : $S{make_build_target_done_0};
990    $R->report(
991        {level => $R->FAIL, type => $R->TYPE_ERR},
992        sprintf(
993            $tmpl,
994            $target->get_task(),
995            (defined($elapsed_time) ? ($elapsed_time) : ()),
996            '!',
997            $target->get_key(),
998            $target->get_ns(),
999        ),
1000    );
1001}
1002
1003# Notification when make-build ignores a missing dependency from a target.
1004sub _event_make_build_target_missing_dep {
1005    $R->report(
1006        {level => $R->WARN, type => $R->TYPE_ERR},
1007        sprintf($S{make_build_target_missing_dep}, @_),
1008    );
1009}
1010
1011# Notification when make-build generates a target from source.
1012sub _event_make_build_target_from_ns {
1013    $R->report(
1014        {level => $R->HIGH},
1015        sprintf($S{make_build_target_from_ns}, @_),
1016    );
1017}
1018
1019# Notification when make-build chooses a list of targets to build.
1020sub _event_make_build_target_select {
1021    my ($target_set_ref) = @_;
1022    $R->report(
1023        {level => $R->HIGH},
1024        sub {
1025            map {
1026                my $key = $_;
1027                my $target = $target_set_ref->{$key};
1028                sprintf(
1029                    $S{make_build_target_select},
1030                    $target->get_task(), $target->get_category(), $key,
1031                );
1032            }
1033            sort keys(%{$target_set_ref});
1034        },
1035    );
1036}
1037
1038# Notification when make-build checks a target for cyclic dependency.
1039sub _event_make_build_target_stack {
1040    my ($key, $rank, $n_deps) = @_;
1041    $R->report(
1042        {level => $R->HIGH},
1043        sub {
1044            my $indent = q{ - } x $rank;
1045            my $more
1046                = $n_deps ? sprintf($S{make_build_target_stack_more}, $n_deps)
1047                :           q{}
1048                ;
1049            sprintf($S{make_build_target_stack}, $indent, $key, $more),
1050        },
1051    );
1052}
1053
1054# Notification when make-build fails to update some targets.
1055sub _event_make_build_targets_fail {
1056    my ($targets_ref) = @_;
1057    $R->report(
1058        {type => $R->TYPE_ERR, level => $R->FAIL},
1059        (map {
1060            my $target = $_;
1061            my @failed_by = @{$target->get_failed_by()};
1062            my @lines;
1063            if (grep {$_ eq $target->get_key()} @failed_by) {
1064                push(
1065                    @lines,
1066                    sprintf($S{make_build_targets_fail_1}, $target->get_key()),
1067                );
1068            }
1069            for my $failed_by_key (grep {$_ ne $target->get_key()} @failed_by) {
1070                push(
1071                    @lines,
1072                    sprintf(
1073                        $S{make_build_targets_fail_0},
1074                        $target->get_key(),
1075                        $failed_by_key,
1076                    ),
1077                );
1078            }
1079            @lines;
1080        } sort {$a->get_key() cmp $b->get_key()} @{$targets_ref}),
1081    );
1082}
1083
1084# Notification when make-extract finished gathering information for its project
1085# source trees.
1086sub _event_make_extract_project_tree {
1087    my %locators_of = %{$_[0]};
1088    for my $ns (sort(keys(%locators_of))) {
1089        my $i = 0;
1090        for my $locator (@{$locators_of{$ns}}) {
1091            my $format_last_mod_rev = q{};
1092            if ($locator->get_last_mod_rev()) {
1093                $format_last_mod_rev = sprintf(
1094                    $S{'make_extract_project_tree_1'},
1095                    $locator->get_last_mod_rev(),
1096                );
1097            }
1098            $R->report(
1099                sprintf(
1100                    $S{'make_extract_project_tree'},
1101                    $ns, $i++, $locator->get_value(), $format_last_mod_rev
1102                ),
1103            );
1104        }
1105    }
1106}
1107
1108# Notification when make-extract used the task runner to perform tasks.
1109sub _event_make_extract_runner_summary {
1110    $R->report(
1111        {level => $R->HIGH},
1112        sprintf($S{'make_extract_runner_summary'}, @_),
1113    );
1114}
1115
1116# Notification when make-extract completes updating its targets.
1117sub _event_make_extract_target_summary {
1118    my ($basket) = @_;
1119    for (
1120        [   'status',
1121            'make_extract_target_summary_d',
1122            \%MAKE_EXTRACT_TARGET_SYM_OF,
1123        ],
1124        [   'status_of_source',
1125            'make_extract_target_summary_s',
1126            \%MAKE_EXTRACT_SOURCE_SYM_OF,
1127        ],
1128    ) {
1129        my ($name, $format_name, $sym_hash_ref) = @{$_};
1130        for my $key (sort keys(%{$basket->{$name}})) {
1131            $R->report(sprintf(
1132                $S{$format_name},
1133                $basket->{$name}{$key},
1134                $sym_hash_ref->{$key}[0],
1135                $sym_hash_ref->{$key}[1],
1136            ));
1137        }
1138    }
1139}
1140
1141# Notification when make-extract ignores a symlink.
1142sub _event_make_extract_symlink {
1143    my ($source) = @_;
1144    $R->report(
1145        {type => $R->TYPE_ERR},
1146        sprintf($S{make_extract_symlink}, $source->get_locator()->get_value()),
1147    );
1148}
1149
1150# Notification when make-extract updates a target.
1151sub _event_make_extract_target {
1152    my ($target) = @_;
1153    if (!exists($MAKE_EXTRACT_TARGET_SYM_OF{$target->get_status()})) {
1154        return;
1155    }
1156    $R->report(
1157        {level => $R->MEDIUM},
1158        sub {
1159            my ($verbosity) = @_;
1160            if ($verbosity < $R->DEBUG && $target->is_unchanged()) {
1161                return;
1162            }
1163            my ($ns, $path) = split(qr{/}msx, $target->get_ns(), 2);
1164            my %source_of = %{$target->get_source_of()};
1165            my $base = delete($source_of{0});
1166            my @diff_keys
1167                = grep {!$source_of{$_}->is_unchanged()} keys(%source_of);
1168            my @st_missing_diff_keys
1169                = grep {$source_of{$_}->is_missing()} @diff_keys;
1170            if (@st_missing_diff_keys) {
1171                @diff_keys = @st_missing_diff_keys;
1172            }
1173            sprintf(
1174                $S{make_extract_target},
1175                $MAKE_EXTRACT_TARGET_SYM_OF{$target->get_status()}[0],
1176                $MAKE_EXTRACT_SOURCE_SYM_OF{$target->get_status_of_source()}[0],
1177                $ns,
1178                join(
1179                q{,},
1180                    (   defined($base) && defined($base->get_locator())
1181                            ? ($S{make_extract_target_base_yes})
1182                            : ($S{make_extract_target_base_no})
1183                    ),
1184                    sort({$a <=> $b} @diff_keys),
1185                ),
1186                $path,
1187            );
1188        },
1189    );
1190}
1191
1192# Returns a CODE to perform a simple notification with sprintf format.
1193sub _func {
1194    my ($id) = @_;
1195    sub {$R->report(sprintf($S{$id}, @_))};
1196}
1197
1198# ------------------------------------------------------------------------------
11991;
1200__END__
1201
1202=head1 NAME
1203
1204FCM::Util::Event
1205
1206=head1 SYNOPSIS
1207
1208    use FCM::Util::Event;
1209    $event_handler = FCM::Util::Event->new(\%attrib);
1210    $event_handler->($event);
1211
1212=head1 DESCRIPTION
1213
1214Handles events wrapped as L<FCM::Context::Event|FCM::Context::Event> objects by
1215stringifying and reporting them.
1216
1217This module is part of L<FCM::Util|FCM::Util>. See also the description of the
1218$u->report() method in L<FCM::Util|FCM::Util>.
1219
1220=head1 METHODS
1221
1222=over 4
1223
1224=item $class->new(\%attrib)
1225
1226Returns a new instance. The %attrib HASH can have the following elements:
1227
1228=over 4
1229
1230=item util
1231
1232The parent L<FCM::Util|FCM::Util> object.
1233
1234=back
1235
1236=item $util->event($event_ctx)
1237
1238Notification of an $event_ctx, which should be a blessed reference of
1239L<FCM::Context::Event|FCM::Context::Event>.
1240
1241=back
1242
1243=head1 TODO
1244
1245Modularise?
1246
1247=head1 COPYRIGHT
1248
1249Copyright (C) 2006-2021 British Crown (Met Office) & Contributors.
1250
1251=cut
Note: See TracBrowser for help on using the repository browser.