# ------------------------------------------------------------------------------
# (C) British Crown Copyright 2006-17 Met Office.
#
# 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::Reporter;
use base qw{FCM::Class::CODE};
use Scalar::Util qw{reftype};
use constant {TYPE_OUT => 1, TYPE_ERR => 2};
use constant { DEFAULT => 1,
FAIL => 0, WARN => 1,
QUIET => 0, LOW => 1, MEDIUM => 2, HIGH => 3, DEBUG => 4,
};
use constant {
PREFIX_DONE => q{[done] },
PREFIX_FAIL => q{[FAIL] },
PREFIX_INFO => q{[info] },
PREFIX_INIT => q{[init] },
PREFIX_NULL => q{},
PREFIX_QUIT => q{[quit] },
PREFIX_WARN => q{[WARN] },
};
# Creates the class.
__PACKAGE__->class(
{ctx_of => '%'},
{ init => sub {
my ($attrib_ref) = @_;
%{$attrib_ref->{ctx_of}} = (
stderr => FCM::Util::Reporter::Context->new_err(),
stdout => FCM::Util::Reporter::Context->new(),
);
},
action_of => {
add_ctx => \&_add_ctx,
del_ctx => \&_del_ctx,
get_ctx => \&_get_ctx,
get_ctx_of_stderr => sub {$_[0]->{ctx_of}->{stderr}},
get_ctx_of_stdout => sub {$_[0]->{ctx_of}->{stdout}},
report => \&_report,
}
},
);
# Adds a named reporter context.
sub _add_ctx {
my ($attrib_ref, $key, @args) = @_;
if (exists($attrib_ref->{ctx_of}->{$key})) {
return;
}
$attrib_ref->{ctx_of}->{$key} = FCM::Util::Reporter::Context->new(@args);
}
# Deletes a named reporter context.
sub _del_ctx {
my ($attrib_ref, $key) = @_;
if (!exists($attrib_ref->{ctx_of}->{$key})) {
return;
}
delete($attrib_ref->{ctx_of}->{$key});
}
# Returns a named reporter context.
sub _get_ctx {
my ($attrib_ref, $key) = @_;
if (!exists($attrib_ref->{ctx_of}->{$key})) {
return;
}
$attrib_ref->{ctx_of}->{$key};
}
# Reports message.
sub _report {
my ($attrib_ref, @args) = @_;
if (!@args) {
return;
}
my %option = (
delimiter => "\n",
level => DEFAULT,
prefix => undef,
type => TYPE_OUT,
);
if (ref($args[0]) && reftype($args[0]) eq 'HASH') {
%option = (%option, %{shift(@args)});
}
# Auto remove ctx with closed file handle
while (my ($key, $ctx) = each(%{$attrib_ref->{ctx_of}})) {
if (!defined(fileno($ctx->get_handle()))) {
delete($attrib_ref->{ctx_of}->{$key});
}
}
# Selects handles
my @ctx_and_prefix_list
= map {
my $prefix = defined($option{prefix})
? $option{prefix} : $_->get_prefix();
if (ref($prefix) && reftype($prefix) eq 'CODE') {
$prefix = $prefix->($option{level}, $option{type});
}
[$_, $prefix],
}
grep { (!$_->get_type() || $_->get_type() eq $option{type})
&& $_->get_verbosity() >= $option{level}
}
values(%{$attrib_ref->{ctx_of}});
if (!@ctx_and_prefix_list) {
return;
}
for my $arg (@args) {
for (@ctx_and_prefix_list) {
my ($ctx, $prefix) = @{$_};
my $handle = $ctx->get_handle();
if ($option{delimiter}) {
for my $item (
map {grep {$_ ne "\n"} split(qr{(\n)}msx)} (
!ref($arg) ? ($arg)
: reftype($arg) eq 'ARRAY' ? @{$arg}
: reftype($arg) eq 'CODE' ? $arg->($ctx->get_verbosity())
: ($arg)
)
) {
print({$handle} $prefix . $item . $option{delimiter});
}
}
else {
print({$handle} $arg);
}
}
}
1;
}
# ------------------------------------------------------------------------------
package FCM::Util::Reporter::Context;
use base qw{FCM::Class::HASH};
# Creates the class.
__PACKAGE__->class(
{ handle => {isa => '*', default => \*STDOUT },
prefix => { default => sub {\&_prefix} },
type => {isa => '$', default => FCM::Util::Reporter->TYPE_OUT},
verbosity => {isa => '$', default => FCM::Util::Reporter->DEFAULT },
},
);
# Returns a new reporter context to STDERR.
sub new_err {
my ($class, $attrib_ref) = @_;
$class->new({
handle => \*STDERR,
type => FCM::Util::Reporter->TYPE_ERR,
(defined($attrib_ref) ? %{$attrib_ref} : ()),
});
}
# The default prefix function.
sub _prefix {
my ($level, $type) = @_;
$type eq FCM::Util::Reporter->TYPE_OUT ? FCM::Util::Reporter->PREFIX_INFO
: $level > FCM::Util::Reporter->FAIL ? FCM::Util::Reporter->PREFIX_WARN
: FCM::Util::Reporter->PREFIX_FAIL
;
}
# ------------------------------------------------------------------------------
1;
__END__
=head1 NAME
FCM::Reporter
=head1 SYNOPSIS
use FCM::Util::Reporter;
$reporter = FCM::Util::Reporter->new({verbosity => $verbosity});
$reporter->($message);
$reporter->(\@messages);
$reporter->(sub {return @some_strings});
$reporter->({level => $reporter->MEDIUM}, $message);
=head1 DESCRIPTION
A simple message reporter.
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 of this class, which is a CODE reference. %attrib can
contain the following:
=over 4
=item ctx_of
A HASH containing a map to the named reporter contexts. At initialisation, a new
ctx for "stdout" and a new ctx for "stderr" is created automatically.
=back
=item $reporter->add_ctx($key,%option)
Creates a new reporter context, and adds it to the ctx_of HASH, if a context
with the same $key does not already exist. The %option is given to the
constructir of L. Return the context on success.
=item $reporter->del_ctx($key)
Removes a new reporter context named $key. Return the context on success.
=item $reporter->get_ctx($key)
Returns a named reporter context L.
=item $reporter->get_ctx_of_stderr()
Shorthand for $reporter->get_ctx('stderr').
=item $reporter->get_ctx_of_stdout()
Shorthand for $reporter->get_ctx('stdout').
=item $reporter->report(\%option,$message)
Reports the message. If %option is not given, reports using the default options.
In the form, the following %options can be specified:
=over 4
=item delimiter
The delimiter of each message in the list. The default is "\n". If the delimiter
is set to the empty string, the items in $message will be treated as raw
strings, i.e. it will also ignore any "prefix" options.
=item level
The level of the current message. The default is DEFAULT.
=item prefix
The message prefix. It can be a string or a CODE reference. If it is a string,
it is simply preprended to the message. If it is a code reference, it is calls
as $prefix_ref->($option{level}, $option{type}), and its result (if defined) is
prepended to the message.
=item type
The message type. It can be REPORT_ERR or REPORT_OUT (default).
=back
=back
=head1 CONSTANTS
=over 4
=item $reporter->FAIL, $reporter->QUIET
The verbosity level 0.
=item $reporter->DEFAULT, $reporter->LOW, $reporter->WARN
The verbosity level 1.
=item $reporter->MEDIUM
The verbosity level 2.
=item $reporter->HIGH
The verbosity level 3.
=item $reporter->DEBUG
The verbosity level 4.
=item $reporter->PREFIX_DONE
The prefix for a task "done" message.
=item $reporter->PREFIX_FAIL
The prefix for a fatal error message.
=item $reporter->PREFIX_INFO
The prefix for an "info" message.
=item $reporter->PREFIX_INIT
The prefix for a task "init" message.
=item $reporter->PREFIX_NULL
An empty string.
=item $reporter->PREFIX_QUIT
The prefix for a quit/abort message.
=item $reporter->PREFIX_WARN
The prefix for a warning message.
=item $reporter->REPORT_ERR
The message type for exception message.
=item $reporter->REPORT_OUT
The message type for info message.
=back
=head1 FCM::Util::Reporter::Context
An instance of this class represents the context for a reporter for the
Lreport()|FCM::Util>. This class is a sub-class of
L. It has the following attributes:
=over 4
=item handle
The file handle for info messages. (Default=\*STDOUT)
=item prefix
The message prefix. It can be a string or a CODE reference. If it is a string,
it is simply preprended to the message. If it is a code reference, it is calls
as $prefix_ref->($option{level}, $option{type}), and its result (if defined) is
prepended to the message. The default is a CODE that returns PREFIX_INFO for
TYPE_OUT messages, PREFIX_WARN for TYPE_ERR messages at WARN level or above or
PREFIX_FAIL for TYPE_ERR messages at FAIL level.
=item type
Reporter type. (Default=TYPE_OUT)
=item verbosity
The verbosity of the reporter. Only messages at a level above or equal to the
verbosity will be reported. The default is DEFAULT.
=back
=head1 COPYRIGHT
(C) Crown copyright Met Office. All rights reserved.
=cut