# ------------------------------------------------------------------------------
# Copyright (C) 2006-2021 British Crown (Met Office) & Contributors.
#
# This file is part of FCM, tools for managing and building source code.
#
# FCM is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# FCM is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with FCM. If not, see .
# ------------------------------------------------------------------------------
use strict;
use warnings;
# ------------------------------------------------------------------------------
package FCM::Util::Event;
use base qw{FCM::Class::CODE};
use Data::Dumper qw{Dumper};
use FCM::Context::Event;
use File::Basename qw{basename};
use List::Util qw{first};
use POSIX qw{strftime};
use Scalar::Util qw{blessed};
my $CTX = 'FCM::Context::Event';
my $IS_MULTI_LINE = 1;
# Event keys and their actions.
my %ACTION_OF = (
$CTX->CM_ABORT => \&_event_cm_abort,
$CTX->CM_BRANCH_CREATE_SOURCE => _func('cm_branch_create_source'),
$CTX->CM_BRANCH_LIST => \&_event_cm_branch_list,
$CTX->CM_COMMIT_MESSAGE => \&_event_cm_commit_message,
$CTX->CM_CONFLICT_TEXT => _func('cm_conflict_text'),
$CTX->CM_CONFLICT_TEXT_SKIP => \&_event_cm_conflict_text_skip,
$CTX->CM_CONFLICT_TREE => _func('cm_conflict_tree'),
$CTX->CM_CONFLICT_TREE_SKIP => \&_event_cm_conflict_tree_skip,
$CTX->CM_CONFLICT_TREE_TIME_WARN => \&_event_cm_conflict_tree_time_warn,
$CTX->CM_CREATE_TARGET => _func('cm_create_target'),
$CTX->CM_LOG_EDIT => _func('cm_log_edit'),
$CTX->CONFIG_OPEN => \&_event_config_open,
$CTX->CONFIG_ENTRY => \&_event_config_entry,
$CTX->CONFIG_VAR_UNDEF => \&_event_config_var_undef,
$CTX->E => \&_event_e,
$CTX->EXPORT_ITEM_CREATE => _func('export_item_create'),
$CTX->EXPORT_ITEM_DELETE => _func('export_item_delete'),
$CTX->FCM_VERSION => _func('fcm_version'),
$CTX->KEYWORD_ENTRY => \&_event_keyword_entry,
$CTX->MAKE_BUILD_SHELL_OUT => \&_event_make_build_shell_out,
$CTX->MAKE_BUILD_SOURCE_ANALYSE => \&_event_make_build_source_analyse,
$CTX->MAKE_BUILD_SOURCE_SUMMARY => _func('make_build_source_summary'),
$CTX->MAKE_BUILD_TARGET_DONE => \&_event_make_build_target_done,
$CTX->MAKE_BUILD_TARGET_FAIL => \&_event_make_build_target_fail,
$CTX->MAKE_BUILD_TARGET_FROM_NS => \&_event_make_build_target_from_ns,
$CTX->MAKE_BUILD_TARGET_SELECT => \&_event_make_build_target_select,
$CTX->MAKE_BUILD_TARGET_SELECT_TIMER=> _func('make_build_target_select_t'),
$CTX->MAKE_BUILD_TARGET_MISSING_DEP => \&_event_make_build_target_missing_dep,
$CTX->MAKE_BUILD_TARGET_STACK => \&_event_make_build_target_stack,
$CTX->MAKE_BUILD_TARGET_SUMMARY => _func('make_build_target_sum'),
$CTX->MAKE_BUILD_TARGET_TASK_SUMMARY=> _func('make_build_target_task_sum'),
$CTX->MAKE_BUILD_TARGETS_FAIL => \&_event_make_build_targets_fail,
$CTX->MAKE_DEST => \&_event_make_dest,
$CTX->MAKE_EXTRACT_PROJECT_TREE => \&_event_make_extract_project_tree,
$CTX->MAKE_EXTRACT_RUNNER_SUMMARY => \&_event_make_extract_runner_summary,
$CTX->MAKE_EXTRACT_SYMLINK => \&_event_make_extract_symlink,
$CTX->MAKE_EXTRACT_TARGET => \&_event_make_extract_target,
$CTX->MAKE_EXTRACT_TARGET_SUMMARY => \&_event_make_extract_target_summary,
$CTX->MAKE_MIRROR => \&_event_make_mirror,
$CTX->OUT => \&_event_out,
$CTX->SHELL => \&_event_shell,
$CTX->TASK_WORKERS => \&_event_task_workers,
$CTX->TIMER => \&_event_timer,
);
# Helper for "_event_e", list of exception classes and their formatters.
our @E_FORMATTERS = (
['FCM1::Cm::Exception' , \&_format_e_cm ],
['FCM1::CLI::Exception' , sub {$_[0]->get_message()}],
['FCM::Class::Exception' , \&_format_e_class ],
['FCM::CLI::Exception' , \&_format_e_cli ],
['FCM::System::Exception', \&_format_e_sys ],
['FCM::Util::Exception' , \&_format_e_util ],
);
# Error format strings for FCM1::Cm::Exception.
our %E_CM_FORMAT_FOR = (
DIFF_PROJECTS => "%s (target) and %s (source) are not related.\n",
INVALID_BRANCH => "%s: not a valid URL of a standard FCM branch.\n",
INVALID_PROJECT => "%s: not a valid URL of a standard FCM project.\n",
INVALID_TARGET => "%s: not a valid working copy or URL.\n",
INVALID_URL => "%s: not a valid URL.\n",
INVALID_WC => "%s: not a valid working copy.\n",
MERGE_REV_INVALID => "%s: not a revision in the available merge list.\n",
MERGE_SELF => "%s: cannot be merged to its own working copy: %s.\n",
MERGE_UNRELATED => "%s: target and %s: source not directly related.\n",
MERGE_UNSAFE => "%s: source contains changes outside the target"
. " sub-directory. Please merge with a full tree.\n",
MKPATH => "%s: cannot create directory.\n",
NOT_EXIST => "%s: does not exist.\n",
PARENT_NOT_EXIST => "%s: parent %s no longer exists.\n",
RMTREE => "%s: cannot remove.\n",
ST_CONFLICT => "File(s) in conflicts:\n%s",
ST_MISSING => "File(s) missing:\n%s",
ST_OUT_OF_DATE => "File(s) out of date:\n%s",
SWITCH_UNSAFE => "%s: merge template exists."
. " Please remove before retrying.\n",
WC_INVALID_BRANCH => "%s: not a working copy of a standard FCM branch.\n",
WC_URL_NOT_EXIST => "%s: working copy URL does not exists at HEAD.\n",
);
# Helper for "_format_e_sys", formatters based on exception code.
our %E_SYS_FORMATTER_FOR = (
BUILD_SOURCE => _format_e_func('e_sys_build_source'),
BUILD_SOURCE_SYN => _format_e_func('e_sys_build_source_syn'),
BUILD_TARGET => \&_format_e_sys_build_target,
BUILD_TARGET_BAD => _format_e_func('e_sys_build_target_bad', $IS_MULTI_LINE),
BUILD_TARGET_CYC => \&_format_e_sys_build_target_cyc,
BUILD_TARGET_DEP => \&_format_e_sys_build_target_dep,
BUILD_TARGET_DUP => \&_format_e_sys_build_target_dup,
CACHE_LOAD => _format_e_func('e_sys_cache_load'),
CACHE_TYPE => _format_e_func('e_sys_cache_type'),
CM_ALREADY_EXIST => _format_e_func('e_sys_cm_already_exist'),
CM_ARG => _format_e_func('e_sys_cm_arg'),
CM_BRANCH_NAME => _format_e_func('e_sys_cm_branch_name'),
CM_BRANCH_SOURCE => _format_e_func('e_sys_cm_branch_source'),
CM_CHECKOUT => _format_e_func('e_sys_cm_checkout'),
CM_LOG_EDIT_NULL => _format_e_func('e_sys_cm_log_edit_null'),
CM_LOG_EDIT_DELIMITER => _format_e_func('e_sys_cm_log_edit_delimiter'),
CM_OPT_ARG => _format_e_func('e_sys_cm_opt_arg'),
CM_PROJECT_NAME => _format_e_func('e_sys_cm_project_name'),
CM_REPOSITORY => _format_e_func('e_sys_cm_repository'),
CONFIG_CONFLICT => _format_e_sys_config_func('conflict'),
CONFIG_INHERIT => _format_e_sys_config_func('inherit'),
CONFIG_MODIFIER => _format_e_sys_config_func('modifier'),
CONFIG_NS => _format_e_sys_config_func('ns'),
CONFIG_NS_VALUE => _format_e_sys_config_func('ns_value'),
CONFIG_UNKNOWN => _format_e_sys_config_func('unknown'),
CONFIG_VALUE => _format_e_sys_config_func('value'),
CONFIG_VERSION => _format_e_sys_config_func('version'),
COPY => _format_e_func('e_sys_copy'),
DEST_CLEAN => _format_e_func('e_sys_dest_clean'),
DEST_CREATE => _format_e_func('e_sys_dest_create'),
DEST_LOCK => _format_e_func('e_sys_dest_lock'),
DEST_LOCKED => _format_e_func('e_sys_dest_locked'),
EXPORT_ITEMS_SRC => _format_e_func('e_sys_export_items_src'),
EXTRACT_LOC_BASE => _format_e_func('e_sys_extract_loc_base'),
EXTRACT_MERGE => \&_format_e_sys_extract_merge,
EXTRACT_NS => _format_e_func('e_sys_extract_ns', $IS_MULTI_LINE),
MIRROR => \&_format_e_sys_mirror,
MIRROR_NULL => _format_e_func('e_sys_mirror_null'),
MIRROR_SOURCE => _format_e_func('e_sys_mirror_source', $IS_MULTI_LINE),
MIRROR_TARGET => _format_e_func('e_sys_mirror_target'),
MAKE => _format_e_func('e_sys_make'),
MAKE_ARG => \&_format_e_sys_make_arg,
MAKE_CFG => _format_e_func('e_sys_make_cfg'),
MAKE_CFG_FILE => _format_e_func('e_sys_make_cfg_file'),
MAKE_PROP_NS => \&_format_e_sys_make_prop_ns,
MAKE_PROP_VALUE => \&_format_e_sys_make_prop_value,
SHELL => \&_format_e_sys_shell,
);
# Helper for "_format_e_util", formatters based on exception code.
our %E_UTIL_FORMATTER_FOR = (
CLASS_LOADER => _format_e_func('e_util_class_loader'),
CONFIG_CONT_EOF => _format_e_util_config_func('eof'),
CONFIG_CYCLIC => _format_e_util_config_stack_func('cyclic'),
CONFIG_LOAD => _format_e_util_config_stack_func('load'),
CONFIG_SYNTAX => _format_e_util_config_func('syntax'),
CONFIG_USAGE => _format_e_util_config_func('usage'),
CONFIG_VAR_UNDEF => _format_e_util_config_func('var_undef'),
IO => _format_e_func('e_util_io'),
LOCATOR_AS_INVARIANT => _format_e_util_locator_func(''),
LOCATOR_BROWSER_URL => _format_e_util_locator_func('_browser_url'),
LOCATOR_FIND => _format_e_util_locator_func(''),
LOCATOR_KEYWORD_LOC => _format_e_util_locator_func('_keyword_loc'),
LOCATOR_KEYWORD_REV => _format_e_util_locator_func('_keyword_rev'),
LOCATOR_READER => _format_e_util_locator_func('_reader'),
LOCATOR_TYPE => _format_e_util_locator_func('_type'),
SHELL_OPEN3 => _format_e_util_shell_func('_open3'),
SHELL_OS => _format_e_util_shell_func('_os'),
SHELL_SIGNAL => _format_e_util_shell_func('_signal'),
SHELL_WHICH => _format_e_util_shell_func('_which'),
);
# Alias
our $R;
# Named diagnostic strings
our %S = (
# ERROR DIAGNOSTICS
e_class => '%s: %s => %s: internal error at %s:%d',
e_cli_app => '%s: unknown command,'
. ' type \'%s help\' for help',
e_cli_opt => '%s: incorrect usage,'
. ' type \'%s help %1$s\' for help',
e_sys_build_source => '%s: source does not exist',
e_sys_build_source_syn => '%s(%d): syntax error',
e_sys_build_target => '%s: target not found after an update:',
e_sys_build_target_1 => '%s: expect target file',
e_sys_build_target_bad => '%s: don\'t know how to build specified'
. ' target',
e_sys_build_target_cyclic => '%s: target depends on itself',
e_sys_build_target_dep => '%s: bad or missing dependency (type=%s)',
e_sys_build_target_dup => '%s: same target from [%s]',
e_sys_build_target_stack => ' required by: %s',
e_sys_cache_load => '%s: cannot retrieve cache',
e_sys_cache_type => '%s: unexpected cache type',
e_sys_cm_already_exist => '%s: already exists',
e_sys_cm_arg => '%s: bad argument',
e_sys_cm_branch_name => '%s: invalid branch name',
e_sys_cm_branch_source => '%s: invalid branch source',
e_sys_cm_checkout => '%s: is already a working copy of %s',
e_sys_cm_log_edit_delimiter => '%sthe above log delimiter is altered',
e_sys_cm_log_edit_null => 'log message is empty',
e_sys_cm_opt_arg => '%s=%s: bad option argument',
e_sys_cm_project_name => '%s: invalid project name',
e_sys_cm_repository => '%s: invalid repository',
e_sys_config_conflict => '%s: cannot modify, value is inherited',
e_sys_config_inherit => '%s: cannot inherit from an incomplete make',
e_sys_config_modifier => '%s: incorrect modifier in declaration',
e_sys_config_ns => '%s: incorrect name-space declaration',
e_sys_config_ns_value => '%s: mismatch between name-space and value',
e_sys_config_unknown => '%s: unknown declaration',
e_sys_config_value => '%s: incorrect value in declaration',
e_sys_config_version => '%s: requested version mismatch',
e_sys_copy => '%s -> %s: copy failed',
e_sys_dest_clean => '%s: cannot remove',
e_sys_dest_create => '%s: cannot create',
e_sys_dest_locked => '%s: lock exists at the destination',
e_sys_export_items_src => 'source location not specified',
e_sys_extract_loc_base => '%s: cannot determine base location',
e_sys_extract_merge => '%s: merge results in conflict',
e_sys_extract_merge_output => ' merge output: %s',
e_sys_extract_merge_source => ' source from location %2d: %s',
e_sys_extract_merge_source_0 => '(none)',
e_sys_extract_merge_source_x => '!!! source from location %2d: %s',
e_sys_extract_ns => '%s: name-spaces declared but not used',
e_sys_mirror => '%s <- %s: mirror failed',
e_sys_mirror_null => 'mirror target not specified',
e_sys_mirror_source => '%s: cannot mirror this step',
e_sys_mirror_target => '%s: cannot create mirror target',
e_sys_make => '%s: step is not implemented',
e_sys_make_arg => 'arg %d (%s): invalid config declaration',
e_sys_make_arg_more => 'did you mean "%s"?',
e_sys_make_cfg => 'no configuration specified or found',
e_sys_make_cfg_file => '%s: no such configuration file',
e_sys_make_prop_ns => '%s.prop{%s}[%s] = %s: bad name-space',
e_sys_make_prop_value => '%s.prop{%s}[%s] = %s: bad value',
e_sys_shell => '%s # rc=%d',
e_unknown => 'command failed',
e_util_class_loader => '%s: required package cannot be loaded',
e_util_config => '%s:%d: %s',
e_util_config_eof => 'continuation at eof',
e_util_config_syntax => 'syntax error',
e_util_config_usage => 'incorrect usage',
e_util_config_var_undef => 'reference to undefined variable',
e_util_config_stack_cyclic => '%s: cannot load config file,'
. ' cyclic dependency',
e_util_config_stack_load => '%s: cannot load config file',
e_util_io => '%s: I/O error',
e_util_locator => '%s: not found',
e_util_locator_browser_url => '%s: cannot determine browser URL',
e_util_locator_keyword_loc => '%s: location keyword not defined',
e_util_locator_keyword_rev => '%s: revision keyword not defined',
e_util_locator_reader => '%s: cannot be read',
e_util_locator_type => '%s: unsupported type of location',
e_util_shell_open3 => '%s: command failed to invoke',
e_util_shell_os => '%s: command failed due to OS error',
e_util_shell_signal => '%s: command received a signal',
e_util_shell_which => '%s: command not found',
# NORMAL DIAGNOSTICS
cm_abort_null => 'command will result in no change',
cm_abort_user => 'by user',
cm_branch_create_source => 'Source: %s (%d)',
cm_branch_list => '%s: %d match(es)',
cm_commit_message => 'Change summary:' . "\n"
. '-' x 80 . "\n" . '%s'
. '-' x 80 . "\n"
. 'Commit message is as follows:' . "\n"
. '-' x 80 . "\n" . '%s%s'
. '-' x 80,
cm_conflict_text => '%s: in text conflict.',
cm_conflict_text_skip => '%s: skipped binary file in text conflict.',
cm_conflict_tree => '%s: in tree conflict.',
cm_conflict_tree_skip => '%s: skipped unhandled tree conflict.',
cm_conflict_tree_time_warn => '%s: looking for a rename operation,'
. ' please wait...',
cm_create_target => 'Created: %s',
cm_log_edit => '%s: starting commit message editor...',
config_open => 'config-file=%s%s',
config_var_undef => '%s:%d: %s: variable not defined',
event => '%s: event raised',
export_item_create => 'A %s@%s -> %s',
export_item_delete => 'D %s@%s -> %s',
fcm_version => '%s',
keyword_loc => 'location[%s] = %s',
keyword_loc_primary => 'location{primary}[%s] = %s',
keyword_rev => 'revision[%s:%s] = %s',
make_build_shell_out_1 => '[>>&1] ',
make_build_shell_out_2 => '[>>&2] ',
make_build_source_analyse => 'analyse %4.1f %s',
make_build_source_analyse_1 => ' -> (%9s) %s',
make_build_source_summary => 'sources: total=%d, analysed=%d,'
. ' elapsed-time=%.1fs, total-time=%.1fs',
make_build_target_done_0 => '%-9s ---- %s %-20s <- %s',
make_build_target_done_1 => '%-9s %4.1f %s %-20s <- %s',
make_build_target_from_ns => 'source->target %s -> (%s) %s/ %s',
make_build_target_select => 'required-target: %-9s %-7s %s',
make_build_target_select_t => 'target-tree-analysis: elapsed-time=%.1fs',
make_build_target_stack => 'target %s%s%s',
make_build_target_stack_more => ' (n-deps=%d)',
make_build_target_missing_dep=> '%-30s: ignore-missing-dep: (%3$9s) %2$s',
make_build_target_sum => 'TOTAL targets:'
. ' modified=%d, unchanged=%d, failed=%d,'
. ' elapsed-time=%.1fs',
make_build_target_task_sum => '%-9s targets:'
. ' modified=%d, unchanged=%d, failed=%d,'
. ' total-time=%.1fs',
make_build_targets_fail_0 => '! %-20s: depends on failed target: %s',
make_build_targets_fail_1 => '! %-20s: update task failed',
make_description => 'description=%s',
make_dest => 'dest=%s',
make_dest_use => 'use=%s',
make_extract_project_tree => 'location %5s:%2d: %s%s',
make_extract_project_tree_1 => ' (%s)',
make_extract_runner_summary => '%s: n-tasks=%d,'
. ' elapsed-time=%.1fs, total-time=%.1fs',
make_extract_target => '%s%s %5s:%-6s %s',
make_extract_target_base_yes => '0',
make_extract_target_base_no => '-',
make_extract_symlink => 'symlink ignored: %s',
make_extract_target_summary_d=> ' dest: %4d [%1s %s]',
make_extract_target_summary_s=> 'source: %4d [%1s %s]',
make_mirror => '%s <- %s',
make_mode => 'mode=%s',
make_mode_new => 'new',
make_mode_incr => 'incremental',
shell => 'shell(%d %4.1f) %s',
task_workers_destroy => '%s worker processes destroyed',
task_workers_init => '%s worker processes started',
timer_done => '%-20s# %.1fs',
timer_init => '%-20s# %s',
);
# Symbols/Descriptions for a make extract target status.
my %MAKE_EXTRACT_TARGET_SYM_OF = (
ST_ADDED => ['A', 'added' ],
ST_DELETED => ['D', 'deleted' ],
ST_MODIFIED => ['M', 'modified' ],
ST_O_ADDED => ['a', 'added, overriding inherited' ],
ST_O_DELETED => ['d', 'deleted, overriding inherited'],
ST_UNCHANGED => ['U', 'unchanged' ],
ST_UNKNOWN => ['?', 'unknown' ],
);
# Symbols/Descriptions for a make source status.
my %MAKE_EXTRACT_SOURCE_SYM_OF = (
ST_ADDED => ['A', 'added by a diff source tree' ],
ST_DELETED => ['D', 'deleted by a diff source tree' ],
ST_MERGED => ['G', 'merged from 2+ diff source trees'],
ST_MODIFIED => ['M', 'modified by a diff source tree' ],
ST_UNCHANGED => ['U', 'from base' ],
ST_UNKNOWN => ['?', 'unknown' ],
);
# Creates the class.
__PACKAGE__->class({util => '&'}, {action_of => {main => \&_main}});
sub _main {
my ($attrib_ref, $event) = @_;
local($R) = $attrib_ref->{util}->util_of_report();
if (!exists($ACTION_OF{$event->get_code()})) {
return $R->report(
{level => $R->HIGH}, sprintf($S{event}, $event->get_code()),
);
}
$ACTION_OF{$event->get_code()}->(@{$event->get_args()});
}
# Formats a stack of configuration files.
sub _format_config_stack {
my ($config_stack_ref) = @_;
my @config_stack = @{$config_stack_ref};
my $indent_char = q{};
my $return = q{};
my $i = 0;
for my $item (@config_stack) {
my ($locator, $line) = @{$item};
my $indent = q{ - } x $i++;
$return .= sprintf(
$S{'config_open'} . "\n",
$indent, ($locator->get_value() . ($line ? ':' . $line : q{})),
);
}
return $return;
}
# Formats a CM exception.
sub _format_e_cm {
my ($e) = @_;
sprintf($E_CM_FORMAT_FOR{$e->get_code()}, $e->get_targets());
}
# Formats a class exception.
sub _format_e_class {
my ($e) = @_;
sprintf(
$S{e_class},
$e->get_package(),
$e->get_key(),
(defined($e->get_value()) ? $e->get_value() : 'undef'),
@{$e->get_caller()}[1, 2],
);
}
# Formats a CLI exception.
sub _format_e_cli {
my ($e) = @_;
my $format
= $e->get_code() eq $e->APP ? $S{e_cli_app}
: $S{e_cli_opt}
;
sprintf($format, $e->get_ctx()->[0], basename($0));
}
# Formats a system exception.
sub _format_e_sys {
my ($e) = @_;
if (exists($E_SYS_FORMATTER_FOR{$e->get_code()})) {
return $E_SYS_FORMATTER_FOR{$e->get_code()}->($e);
}
$e;
}
# Formats a system exception - CONFIG_*.
sub _format_e_sys_config_func {
my ($suffix) = @_;
my $key = 'e_sys_config_' . $suffix;
sub {
my ($e) = @_;
my @ctx_list
= ref($e->get_ctx()) eq 'ARRAY' ? @{$e->get_ctx()}
: ($e->get_ctx())
;
map {(
sprintf($S{$key}, $_->as_string()),
_format_config_stack($_->get_stack()),
)} @ctx_list;
}
}
# Formats a system exception - BUILD_TARGET.
sub _format_e_sys_build_target {
my ($e) = @_;
my $ctx = $e->get_ctx();
( sprintf($S{e_sys_build_target}, $ctx->get_key()),
sprintf($S{e_sys_build_target_1}, $ctx->get_path()),
);
}
# Formats a system exception - BUILD_TARGET_CYC.
sub _format_e_sys_build_target_cyc {
my ($e) = @_;
my @messages;
while (my ($key, $hash_ref) = each(%{$e->get_ctx()})) {
my ($head, @stack) = reverse(@{$hash_ref->{'keys'}});
push(@messages, sprintf($S{e_sys_build_target_cyclic}, $head));
push(@messages, map {sprintf($S{e_sys_build_target_stack}, $_)} @stack);
}
@messages;
}
# Formats a system exception - BUILD_TARGET_DEP.
sub _format_e_sys_build_target_dep {
my ($e) = @_;
my @messages;
while (my ($key, $hash_ref) = each(%{$e->get_ctx()})) {
my ($head, @stack) = reverse(@{$hash_ref->{'keys'}});
for (@{$hash_ref->{'values'}}) { # [$dep_key, $dep_type]
my ($dep_name, $dep_type, $dep_remark) = @{$_};
if ($dep_remark) {
$dep_type = $dep_remark . '.' . $dep_type;
}
push(
@messages,
sprintf($S{e_sys_build_target_dep}, $dep_name, $dep_type),
);
}
push(@messages, map {sprintf($S{e_sys_build_target_stack}, $_)} @stack);
}
@messages;
}
# Formats a system exception - BUILD_TARGET_DUP.
sub _format_e_sys_build_target_dup {
my ($e) = @_;
my @messages;
while (my ($key, $hash_ref) = each(%{$e->get_ctx()})) {
my ($head, @stack) = reverse(@{$hash_ref->{'keys'}});
my @ns_list = @{$hash_ref->{'values'}};
my $ns = _format_shell_words({'delimiter' => q{, }}, sort(@ns_list));
push(@messages, sprintf($S{e_sys_build_target_dup}, $key, $ns));
push(@messages, map {sprintf($S{e_sys_build_target_stack}, $_)} @stack);
}
@messages;
}
# Formats a system exception - EXTRACT_MERGE.
sub _format_e_sys_extract_merge {
my ($e) = @_;
my $target = $e->get_ctx()->{'target'};
my $source0 = $target->get_source_of()->{0};
my $location_of_0 = $S{e_sys_extract_merge_source_0};
if ($source0->get_locator()) {
$location_of_0 = $source0->get_locator()->get_value();
}
my $key = $e->get_ctx()->{'key'};
my $location_of_key
= $target->get_source_of()->{$key}->get_locator()->get_value();
( sprintf($S{e_sys_extract_merge}, $target->get_ns()),
sprintf($S{e_sys_extract_merge_output}, $e->get_ctx()->{'output'}),
sprintf($S{e_sys_extract_merge_source}, 0, $location_of_0),
( map {sprintf(
$S{e_sys_extract_merge_source},
$_,
$target->get_source_of()->{$_}->get_locator()->get_value(),
)} @{$e->get_ctx()->{'keys_done'}}
),
sprintf($S{e_sys_extract_merge_source_x}, $key, $location_of_key),
( map {sprintf(
$S{e_sys_extract_merge_source},
$_,
$target->get_source_of()->{$_}->get_locator()->get_value(),
)} @{$e->get_ctx()->{'keys_left'}}
),
);
}
# Formats a system exception - MIRROR.
sub _format_e_sys_mirror {
my ($e) = @_;
my ($target, @sources) = @{$e->get_ctx()};
sprintf($S{e_sys_mirror}, $target, _format_shell_words(@sources));
}
# Formats a system exception - MAKE_ARG
sub _format_e_sys_make_arg {
my ($e) = @_;
my @return;
for (@{$e->get_ctx()}) {
my ($arg_index, $arg_value) = @{$_};
push(@return, sprintf($S{e_sys_make_arg}, $arg_index, $arg_value));
my $advice
= $arg_value =~ qr{\.cfg\z}msx ? '-f ' . $arg_value
: $arg_value eq '0' ? '-q'
: $arg_value eq '2' ? '-v'
: $arg_value eq '3' ? '-v -v'
: undef;
if (defined($advice)) {
push(@return, sprintf($S{e_sys_make_arg_more}, $advice));
}
}
return @return;
}
# Formats a system exception - MAKE_PROP_NS
sub _format_e_sys_make_prop_ns {
my ($e) = @_;
map {sprintf($S{e_sys_make_prop_ns}, @{$_})} @{$e->get_ctx()};
}
# Formats a system exception - MAKE_PROP_VALUE
sub _format_e_sys_make_prop_value {
my ($e) = @_;
map {sprintf($S{e_sys_make_prop_value}, @{$_})} @{$e->get_ctx()};
}
# Formats a system exception - SHELL.
sub _format_e_sys_shell {
my ($e) = @_;
my $command = _format_shell_words(@{$e->get_ctx()->{command_list}});
my %value_of = (out => q{}, rc => '?', %{$e->get_ctx()});
return (
#(map {sprintf($S{e_sys_shell_err}, $_)} split("\n", $value_of{err})),
#(map {sprintf($S{e_sys_shell_out}, $_)} split("\n", $value_of{out})),
sprintf($S{e_sys_shell}, $command, $value_of{rc}),
);
}
# Formats a util exception.
sub _format_e_util {
my ($e) = @_;
if (exists($E_UTIL_FORMATTER_FOR{$e->get_code()})) {
return $E_UTIL_FORMATTER_FOR{$e->get_code()}->($e);
}
$e;
}
# Returns a CODE to format a util config-reader exception.
sub _format_e_util_config_func {
my ($id) = @_;
sub {
my ($e) = @_;
( sprintf(
$S{'e_util_config'},
$e->get_ctx()->get_stack()->[-1][0]->get_value(),
$e->get_ctx()->get_stack()->[-1][1],
$S{'e_util_config_' . $id},
),
$e->get_ctx()->as_string(),
);
};
}
# Returns a CODE to format a util config-reader exception where the ctx is the
# locator stack.
sub _format_e_util_config_stack_func {
my ($id) = @_;
sub {
my ($e) = @_;
my @return = (
_format_config_stack($e->get_ctx()),
sprintf(
$S{'e_util_config_stack_' . $id},
$e->get_ctx()->[-1][0]->get_value(),
),
);
@return;
};
}
# Formats a locator exception.
sub _format_e_util_locator_func {
my ($id) = @_;
sub {sprintf($S{'e_util_locator' . $id}, $_[0]->get_ctx()->get_value())};
}
# Formats a shell exception.
sub _format_e_util_shell_func {
my ($id) = @_;
sub {
sprintf(
$S{'e_util_shell' . $id},
_format_shell_words(@{$_[0]->get_ctx()})
);
};
}
# Returns a CODE to format a exception context in a single/multi line.
sub _format_e_func {
my ($id, $is_multi_line) = @_;
sub {
my ($e) = @_;
my @args;
if (defined($e->get_ctx())) {
@args = (ref($e->get_ctx()) || ref($e->get_ctx()) eq 'ARRAY')
? @{$e->get_ctx()} : $e->get_ctx();
}
$is_multi_line
? (map {sprintf($S{$id}, $_)} @args) : (sprintf($S{$id}, @args));
};
}
# Formats a simple reference.
sub _format_ref {
my ($hash_ref) = @_;
local($Data::Dumper::Terse) = 1;
local($Data::Dumper::Indent) = 0;
Dumper($hash_ref);
}
# Formats words into a string suitable for used in a shell command.
sub _format_shell_words {
my %option = ('delimiter' => q{ });
if (@_ && ref($_[0]) && ref($_[0]) eq 'HASH') {
%option = (%option, %{$_[0]});
shift();
}
my (@words) = @_;
join(
$option{'delimiter'},
map {my $s = $_; $s =~ s{(['"\s])}{\\$1}gmsx; $s} @words,
);
}
# Notification on abort of a CM command.
sub _event_cm_abort {
my ($id) = @_;
$R->report(
{level => $R->QUIET, prefix => $R->PREFIX_QUIT, type => $R->TYPE_ERR},
$S{'cm_abort_' . $id},
);
}
# Notification on a project branch listing.
sub _event_cm_branch_list {
my ($project, @branches) = @_;
$R->report(sprintf($S{'cm_branch_list'}, $project, scalar(@branches)));
for my $branch (@branches) {
$R->report({level => $R->QUIET, prefix => $R->PREFIX_NULL}, $branch);
}
}
# Notification on a log message to be used by a commit.
sub _event_cm_commit_message {
my ($ctx) = @_;
$R->report(
{prefix => $R->PREFIX_NULL},
sprintf(
$S{'cm_commit_message'},
$ctx->get_info_part(), $ctx->get_user_part(), $ctx->get_auto_part(),
),
);
}
# Notification on a skipped file in text conflict.
sub _event_cm_conflict_text_skip {
my ($ctx) = @_;
$R->report({type => $R->TYPE_ERR}, sprintf($S{'cm_conflict_text_skip'}, $ctx));
}
# Notification for an unhandled type of tree conflict.
sub _event_cm_conflict_tree_skip {
my ($ctx) = @_;
$R->report({type => $R->TYPE_ERR}, sprintf($S{'cm_conflict_tree_skip'}, $ctx));
}
# Warning that the tree conflict operation search may take some time.
sub _event_cm_conflict_tree_time_warn {
my ($ctx) = @_;
$R->report({type => $R->TYPE_ERR}, sprintf($S{'cm_conflict_tree_time_warn'}, $ctx));
}
# Notification when a config entry is found.
sub _event_config_entry {
my ($entry, $in_fcm1) = @_;
$R->report(
{level => $R->QUIET, prefix => $R->PREFIX_NULL},
$entry->as_string($in_fcm1),
);
}
# Notification for a configuration file open.
sub _event_config_open {
my ($config_stack_ref, $level) = @_;
$R->report(
{level => (defined($level) ? $level : $R->DEBUG)},
sub {
my $value = $config_stack_ref->[-1][0]->get_value();
my $indent = q{ - } x (scalar(@{$config_stack_ref}) - 1);
sprintf($S{config_open}, $indent, $value);
},
);
}
# Notification when a config variable is undefined.
sub _event_config_var_undef {
my ($entry, $symbol) = @_;
$R->report(
{type => $R->TYPE_ERR},
sprintf(
$S{'config_var_undef'},
$entry->get_stack()->[-1][0]->get_value(),
$entry->get_stack()->[-1][1],
$symbol,
),
);
}
# Notification for an exception.
sub _event_e {
my ($exception) = @_;
my @e_stack = ($exception);
while ( blessed($e_stack[-1])
&& $e_stack[-1]->can('get_exception')
&& (my $e = $e_stack[-1]->get_exception())
) {
push(@e_stack, $e);
}
while (my $e = shift(@e_stack)) {
my $formatter;
if (blessed($e)) {
my $item = first {$e->isa($_->[0])} @E_FORMATTERS;
if ($item) {
$formatter = $item->[1];
}
if (!$formatter && $e->can('as_string')) {
$formatter = sub {$e->as_string()};
}
}
elsif (ref($e)) {
$formatter = \&_format_ref;
}
elsif ($e eq "\n") {
chomp($e);
}
$R->report(
{level => $R->FAIL, type => $R->TYPE_ERR},
(defined($formatter) ? $formatter->($e) : $e),
);
}
1;
}
# Notification when a keyword entry is found.
sub _event_keyword_entry {
my ($entry) = @_;
if ($entry->is_implied()) {
return;
}
my @implied_entry_list
= values(%{$entry->get_ctx_of_implied()->get_entry_by_key()});
if (@implied_entry_list) {
$R->report(
{level => $R->QUIET, prefix => $R->PREFIX_NULL},
sprintf(
$S{keyword_loc_primary},
$entry->get_key(),
$entry->get_value(),
),
);
for my $implied_entry (
sort {$a->get_key() cmp $b->get_key()} @implied_entry_list
) {
$R->report(
{level => $R->MEDIUM, prefix => $R->PREFIX_NULL},
sprintf(
$S{keyword_loc},
$implied_entry->get_key(),
$implied_entry->get_value(),
),
);
}
}
else {
$R->report(
{level => $R->QUIET, prefix => $R->PREFIX_NULL},
sprintf($S{keyword_loc}, $entry->get_key(), $entry->get_value()),
);
}
my @revision_entry_list
= values(%{$entry->get_ctx_of_rev()->get_entry_by_key()});
for my $revision_entry (
sort {$a->get_key() cmp $b->get_key()} @revision_entry_list
) {
$R->report(
{level => $R->QUIET, prefix => $R->PREFIX_NULL},
sprintf(
$S{keyword_rev},
$entry->get_key(),
$revision_entry->get_key(),
$revision_entry->get_value(),
),
);
}
1;
}
# Notification of the output from a command.
sub _event_out {
my ($out, $err) = @_;
my %option = (delimiter => q{}, prefix => $R->PREFIX_NULL);
if ($err) {
$R->report({level => $R->WARN, type => $R->TYPE_ERR, %option}, $err);
}
if ($out) {
$R->report({level => $R->QUIET, %option}, $out);
}
}
# Notification of the output from a command invoked by make/build.
sub _event_make_build_shell_out {
my ($out, $err) = @_;
if ($err) {
$R->report(
{ level => $R->HIGH,
prefix => $S{'make_build_shell_out_2'},
type => $R->TYPE_ERR,
},
$err,
);
}
if ($out) {
$R->report(
{level => $R->HIGH, prefix => $S{'make_build_shell_out_1'}},
$out,
);
}
}
# Notification when a make destination is being set up.
sub _event_make_dest {
my ($m_ctx, $authority) = @_;
if ($m_ctx->get_description()) {
$R->report(sprintf($S{make_description}, $m_ctx->get_description()));
}
$R->report(sprintf($S{make_dest}, $authority . ':' . $m_ctx->get_dest()));
$R->report(sprintf(
$S{make_mode},
$S{'make_mode_' . ($m_ctx->get_prev_ctx() ? 'incr' : 'new')},
));
for my $i_ctx (@{$m_ctx->get_inherit_ctx_list()}) {
$R->report(sprintf($S{make_dest_use}, $i_ctx->get_dest()));
}
}
# Notification when performing a mirroring.
sub _event_make_mirror {
my ($target, @sources) = @_;
$R->report(sprintf($S{make_mirror}, $target, _format_shell_words(@sources)));
}
# Notification when the multi-thread task runner initiates its workers.
sub _event_task_workers {
my ($id, $n_workers) = @_;
my $key = 'task_workers_' . $id;
if (exists($S{$key})) {
$R->report({level => $R->HIGH}, sprintf($S{$key}, $n_workers));
}
}
# Notification when invoking a shell command.
sub _event_shell {
my ($names_ref, $rc, $elapsed) = @_;
my $name = _format_shell_words(@{$names_ref});
my $message = sprintf($S{shell}, $rc, $elapsed, $name);
$R->report({level => $R->HIGH}, $message);
}
# Notification when a timer starts/ends.
sub _event_timer {
my ($name, $start, $elapsed, $failed) = @_;
my $message;
if (defined($elapsed)) {
$message = sprintf($S{timer_done}, $name, $elapsed);
}
else {
my $format = '%Y-%m-%dT%H:%M:%SZ';
$message = sprintf(
$S{timer_init}, $name, strftime($format, gmtime($start)));
}
my $prefix
= $failed ? $R->PREFIX_FAIL
: defined($elapsed) ? $R->PREFIX_DONE
: $R->PREFIX_INIT
;
$R->report({prefix => $prefix}, $message);
}
# Notification when make-build analyse a source.
sub _event_make_build_source_analyse {
my ($source, $elapse) = @_;
$R->report(
{level => $R->MEDIUM},
sprintf($S{make_build_source_analyse}, $elapse, $source->get_ns()),
);
for my $dep (@{$source->get_deps()}) {
$R->report(
{level => $R->HIGH},
sprintf($S{make_build_source_analyse_1}, reverse(@{$dep})),
);
}
}
# Notification when make-build has updated or does not need to update a target.
sub _event_make_build_target_done {
my ($target, $elapsed_time) = @_;
my $tmpl = defined($elapsed_time)
? $S{make_build_target_done_1} : $S{make_build_target_done_0};
$R->report(
{level => $R->MEDIUM},
sprintf(
$tmpl,
$target->get_task(),
(defined($elapsed_time) ? ($elapsed_time) : ()),
$MAKE_EXTRACT_TARGET_SYM_OF{$target->get_status()}[0],
$target->get_key(),
$target->get_ns(),
),
);
}
# Notification when make-build a target fails to update or is failed by
# dependencies.
sub _event_make_build_target_fail {
my ($target, $elapsed_time) = @_;
my $tmpl = defined($elapsed_time)
? $S{make_build_target_done_1} : $S{make_build_target_done_0};
$R->report(
{level => $R->FAIL, type => $R->TYPE_ERR},
sprintf(
$tmpl,
$target->get_task(),
(defined($elapsed_time) ? ($elapsed_time) : ()),
'!',
$target->get_key(),
$target->get_ns(),
),
);
}
# Notification when make-build ignores a missing dependency from a target.
sub _event_make_build_target_missing_dep {
$R->report(
{level => $R->WARN, type => $R->TYPE_ERR},
sprintf($S{make_build_target_missing_dep}, @_),
);
}
# Notification when make-build generates a target from source.
sub _event_make_build_target_from_ns {
$R->report(
{level => $R->HIGH},
sprintf($S{make_build_target_from_ns}, @_),
);
}
# Notification when make-build chooses a list of targets to build.
sub _event_make_build_target_select {
my ($target_set_ref) = @_;
$R->report(
{level => $R->HIGH},
sub {
map {
my $key = $_;
my $target = $target_set_ref->{$key};
sprintf(
$S{make_build_target_select},
$target->get_task(), $target->get_category(), $key,
);
}
sort keys(%{$target_set_ref});
},
);
}
# Notification when make-build checks a target for cyclic dependency.
sub _event_make_build_target_stack {
my ($key, $rank, $n_deps) = @_;
$R->report(
{level => $R->HIGH},
sub {
my $indent = q{ - } x $rank;
my $more
= $n_deps ? sprintf($S{make_build_target_stack_more}, $n_deps)
: q{}
;
sprintf($S{make_build_target_stack}, $indent, $key, $more),
},
);
}
# Notification when make-build fails to update some targets.
sub _event_make_build_targets_fail {
my ($targets_ref) = @_;
$R->report(
{type => $R->TYPE_ERR, level => $R->FAIL},
(map {
my $target = $_;
my @failed_by = @{$target->get_failed_by()};
my @lines;
if (grep {$_ eq $target->get_key()} @failed_by) {
push(
@lines,
sprintf($S{make_build_targets_fail_1}, $target->get_key()),
);
}
for my $failed_by_key (grep {$_ ne $target->get_key()} @failed_by) {
push(
@lines,
sprintf(
$S{make_build_targets_fail_0},
$target->get_key(),
$failed_by_key,
),
);
}
@lines;
} sort {$a->get_key() cmp $b->get_key()} @{$targets_ref}),
);
}
# Notification when make-extract finished gathering information for its project
# source trees.
sub _event_make_extract_project_tree {
my %locators_of = %{$_[0]};
for my $ns (sort(keys(%locators_of))) {
my $i = 0;
for my $locator (@{$locators_of{$ns}}) {
my $format_last_mod_rev = q{};
if ($locator->get_last_mod_rev()) {
$format_last_mod_rev = sprintf(
$S{'make_extract_project_tree_1'},
$locator->get_last_mod_rev(),
);
}
$R->report(
sprintf(
$S{'make_extract_project_tree'},
$ns, $i++, $locator->get_value(), $format_last_mod_rev
),
);
}
}
}
# Notification when make-extract used the task runner to perform tasks.
sub _event_make_extract_runner_summary {
$R->report(
{level => $R->HIGH},
sprintf($S{'make_extract_runner_summary'}, @_),
);
}
# Notification when make-extract completes updating its targets.
sub _event_make_extract_target_summary {
my ($basket) = @_;
for (
[ 'status',
'make_extract_target_summary_d',
\%MAKE_EXTRACT_TARGET_SYM_OF,
],
[ 'status_of_source',
'make_extract_target_summary_s',
\%MAKE_EXTRACT_SOURCE_SYM_OF,
],
) {
my ($name, $format_name, $sym_hash_ref) = @{$_};
for my $key (sort keys(%{$basket->{$name}})) {
$R->report(sprintf(
$S{$format_name},
$basket->{$name}{$key},
$sym_hash_ref->{$key}[0],
$sym_hash_ref->{$key}[1],
));
}
}
}
# Notification when make-extract ignores a symlink.
sub _event_make_extract_symlink {
my ($source) = @_;
$R->report(
{type => $R->TYPE_ERR},
sprintf($S{make_extract_symlink}, $source->get_locator()->get_value()),
);
}
# Notification when make-extract updates a target.
sub _event_make_extract_target {
my ($target) = @_;
if (!exists($MAKE_EXTRACT_TARGET_SYM_OF{$target->get_status()})) {
return;
}
$R->report(
{level => $R->MEDIUM},
sub {
my ($verbosity) = @_;
if ($verbosity < $R->DEBUG && $target->is_unchanged()) {
return;
}
my ($ns, $path) = split(qr{/}msx, $target->get_ns(), 2);
my %source_of = %{$target->get_source_of()};
my $base = delete($source_of{0});
my @diff_keys
= grep {!$source_of{$_}->is_unchanged()} keys(%source_of);
my @st_missing_diff_keys
= grep {$source_of{$_}->is_missing()} @diff_keys;
if (@st_missing_diff_keys) {
@diff_keys = @st_missing_diff_keys;
}
sprintf(
$S{make_extract_target},
$MAKE_EXTRACT_TARGET_SYM_OF{$target->get_status()}[0],
$MAKE_EXTRACT_SOURCE_SYM_OF{$target->get_status_of_source()}[0],
$ns,
join(
q{,},
( defined($base) && defined($base->get_locator())
? ($S{make_extract_target_base_yes})
: ($S{make_extract_target_base_no})
),
sort({$a <=> $b} @diff_keys),
),
$path,
);
},
);
}
# Returns a CODE to perform a simple notification with sprintf format.
sub _func {
my ($id) = @_;
sub {$R->report(sprintf($S{$id}, @_))};
}
# ------------------------------------------------------------------------------
1;
__END__
=head1 NAME
FCM::Util::Event
=head1 SYNOPSIS
use FCM::Util::Event;
$event_handler = FCM::Util::Event->new(\%attrib);
$event_handler->($event);
=head1 DESCRIPTION
Handles events wrapped as L objects by
stringifying and reporting them.
This module is part of L. See also the description of the
$u->report() method in L.
=head1 METHODS
=over 4
=item $class->new(\%attrib)
Returns a new instance. The %attrib HASH can have the following elements:
=over 4
=item util
The parent L object.
=back
=item $util->event($event_ctx)
Notification of an $event_ctx, which should be a blessed reference of
L.
=back
=head1 TODO
Modularise?
=head1 COPYRIGHT
Copyright (C) 2006-2021 British Crown (Met Office) & Contributors.
=cut