430 lines
10 KiB
Perl
430 lines
10 KiB
Perl
|
package Zonemaster::Engine::Translator;
|
||
|
|
|
||
|
|
use v5.16.0;
|
||
|
|
use warnings;
|
||
|
|
|
||
|
|
use version; our $VERSION = version->declare("v1.0.8");
|
||
|
|
|
||
|
|
use Carp qw[confess croak];
|
||
|
|
use Locale::Messages qw[textdomain];
|
||
|
|
use Locale::TextDomain qw[Zonemaster-Engine];
|
||
|
|
use POSIX qw[setlocale LC_MESSAGES];
|
||
|
|
use Readonly;
|
||
|
|
|
||
|
|
use Zonemaster::Engine::Test;
|
||
|
|
|
||
|
|
###
|
||
|
|
### Tag descriptions
|
||
|
|
###
|
||
|
|
|
||
|
|
Readonly my %TAG_DESCRIPTIONS => (
|
||
|
|
CANNOT_CONTINUE => sub {
|
||
|
|
__x # SYSTEM:CANNOT_CONTINUE
|
||
|
|
"Not enough data about {domain} was found to be able to run tests.", @_;
|
||
|
|
},
|
||
|
|
DEPENDENCY_VERSION => sub {
|
||
|
|
__x # SYSTEM:DEPENDENCY_VERSION
|
||
|
|
"Using prerequisite module {name} version {version}.", @_;
|
||
|
|
},
|
||
|
|
GLOBAL_VERSION => sub {
|
||
|
|
__x # SYSTEM:GLOBAL_VERSION
|
||
|
|
"Using version {version} of the Zonemaster engine.", @_;
|
||
|
|
},
|
||
|
|
LOGGER_CALLBACK_ERROR => sub {
|
||
|
|
__x # SYSTEM:LOGGER_CALLBACK_ERROR
|
||
|
|
"Logger callback died with error: {exception}", @_;
|
||
|
|
},
|
||
|
|
LOOKUP_ERROR => sub {
|
||
|
|
__x # SYSTEM:LOOKUP_ERROR
|
||
|
|
"DNS query to {ns} for {domain}/{type}/{class} failed with error: {message}", @_;
|
||
|
|
},
|
||
|
|
MODULE_ERROR => sub {
|
||
|
|
__x # SYSTEM:MODULE_ERROR
|
||
|
|
"Fatal error in {module}: {msg}", @_;
|
||
|
|
},
|
||
|
|
MODULE_VERSION => sub {
|
||
|
|
__x # SYSTEM:MODULE_VERSION
|
||
|
|
"Using module {module} version {version}.", @_;
|
||
|
|
},
|
||
|
|
MODULE_END => sub {
|
||
|
|
__x # SYSTEM:MODULE_END
|
||
|
|
"Module {module} finished running.", @_;
|
||
|
|
},
|
||
|
|
NO_NETWORK => sub {
|
||
|
|
__x # SYSTEM:NO_NETWORK
|
||
|
|
"Both IPv4 and IPv6 are disabled.";
|
||
|
|
},
|
||
|
|
UNKNOWN_METHOD => sub {
|
||
|
|
__x # SYSTEM:UNKNOWN_METHOD
|
||
|
|
"Request to run unknown method {testcase} in module {module}.", @_;
|
||
|
|
},
|
||
|
|
UNKNOWN_MODULE => sub {
|
||
|
|
__x # SYSTEM:UNKNOWN_MODULE
|
||
|
|
"Request to run {testcase} in unknown module {module}. Known modules: {module_list}.", @_;
|
||
|
|
},
|
||
|
|
SKIP_IPV4_DISABLED => sub {
|
||
|
|
__x # SYSTEM:SKIP_IPV4_DISABLED
|
||
|
|
"IPv4 is disabled, not sending \"{rrtype}\" query to {ns}.", @_;
|
||
|
|
},
|
||
|
|
SKIP_IPV6_DISABLED => sub {
|
||
|
|
__x # SYSTEM:SKIP_IPV6_DISABLED
|
||
|
|
"IPv6 is disabled, not sending \"{rrtype}\" query to {ns}.", @_;
|
||
|
|
},
|
||
|
|
FAKE_DELEGATION_TO_SELF => sub {
|
||
|
|
__x # SYSTEM:FAKE_DELEGATION_TO_SELF
|
||
|
|
"Name server {ns} not adding fake delegation for domain {domain} to itself.", @_;
|
||
|
|
},
|
||
|
|
FAKE_DELEGATION_IN_ZONE_NO_IP => sub {
|
||
|
|
__x # SYSTEM:FAKE_DELEGATION_IN_ZONE_NO_IP
|
||
|
|
"The fake delegation of domain {domain} includes an in-zone name server {nsname} "
|
||
|
|
. "without mandatory glue (without IP address).",
|
||
|
|
@_;
|
||
|
|
},
|
||
|
|
FAKE_DELEGATION_NO_IP => sub {
|
||
|
|
__x # SYSTEM:FAKE_DELEGATION_NO_IP
|
||
|
|
"The fake delegation of domain {domain} includes a name server {nsname} "
|
||
|
|
. "that cannot be resolved to any IP address.",
|
||
|
|
@_;
|
||
|
|
},
|
||
|
|
PACKET_BIG => sub {
|
||
|
|
__x # SYSTEM:PACKET_BIG
|
||
|
|
"Big packet size ({size}) (try with \"{command}\").", @_;
|
||
|
|
},
|
||
|
|
);
|
||
|
|
|
||
|
|
###
|
||
|
|
### Construction
|
||
|
|
###
|
||
|
|
|
||
|
|
my $instance;
|
||
|
|
|
||
|
|
sub new {
|
||
|
|
my ( $class, %attrs ) = @_;
|
||
|
|
|
||
|
|
$class->initialize( %attrs );
|
||
|
|
|
||
|
|
return $class->instance;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub instance {
|
||
|
|
my ( $class ) = @_;
|
||
|
|
|
||
|
|
if ( !defined $instance ) {
|
||
|
|
$class->initialize();
|
||
|
|
}
|
||
|
|
|
||
|
|
return $instance;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub initialize {
|
||
|
|
my ( $class, %attrs ) = @_;
|
||
|
|
|
||
|
|
if ( defined $instance ) {
|
||
|
|
confess "already initialized";
|
||
|
|
}
|
||
|
|
|
||
|
|
my $locale;
|
||
|
|
if ( exists $attrs{locale} ) {
|
||
|
|
$locale = delete $attrs{locale};
|
||
|
|
|
||
|
|
if ( !defined $locale || ref $locale ne '' ) {
|
||
|
|
confess "argument 'locale' must not be a defined scalar";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
my $obj = {
|
||
|
|
_locale => $locale // _init_locale(),
|
||
|
|
_all_tag_descriptions => $class->_build_all_tag_descriptions(),
|
||
|
|
_last_language => _build_last_language(),
|
||
|
|
};
|
||
|
|
|
||
|
|
$instance = bless $obj, $class;
|
||
|
|
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
|
||
|
|
###
|
||
|
|
### Builder Methods
|
||
|
|
###
|
||
|
|
|
||
|
|
# Get the program's underlying LC_MESSAGES and make sure it can be effectively
|
||
|
|
# updated down the line.
|
||
|
|
#
|
||
|
|
# If the underlying LC_MESSAGES is invalid, it attempts to second guess Perl's
|
||
|
|
# fallback locale.
|
||
|
|
#
|
||
|
|
# Side effects:
|
||
|
|
# * Updates the program's underlying LC_MESSAGES to the returned value.
|
||
|
|
# * Unsets LC_ALL.
|
||
|
|
sub _init_locale {
|
||
|
|
my $locale = setlocale( LC_MESSAGES, "" );
|
||
|
|
|
||
|
|
delete $ENV{LC_ALL};
|
||
|
|
|
||
|
|
if ( !defined $locale ) {
|
||
|
|
my $language = $ENV{LANGUAGE} // "";
|
||
|
|
for my $value ( split /:/, $language ) {
|
||
|
|
if ( $value ne "" && $value !~ /[.]/ ) {
|
||
|
|
$value .= ".UTF-8";
|
||
|
|
}
|
||
|
|
$locale = setlocale( LC_MESSAGES, $value );
|
||
|
|
if ( defined $locale ) {
|
||
|
|
last;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
$locale //= "C";
|
||
|
|
}
|
||
|
|
|
||
|
|
return $locale;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _load_data {
|
||
|
|
my $self = shift;
|
||
|
|
|
||
|
|
my $old_locale = $self->locale;
|
||
|
|
|
||
|
|
$self->locale( 'C' );
|
||
|
|
|
||
|
|
my %data;
|
||
|
|
for my $mod ( keys %{ $self->all_tag_descriptions } ) {
|
||
|
|
for my $tag ( keys %{ $self->all_tag_descriptions->{$mod} } ) {
|
||
|
|
$data{$mod}{$tag} = $self->_translate_tag( $mod, $tag, {} );
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
$self->locale( $old_locale );
|
||
|
|
|
||
|
|
return \%data;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _build_all_tag_descriptions {
|
||
|
|
my ( $class ) = @_;
|
||
|
|
|
||
|
|
my %all_tag_descriptions;
|
||
|
|
|
||
|
|
$all_tag_descriptions{System} = \%TAG_DESCRIPTIONS;
|
||
|
|
foreach my $mod ( Zonemaster::Engine::Test->modules ) {
|
||
|
|
my $module = 'Zonemaster::Engine::Test::' . $mod;
|
||
|
|
$all_tag_descriptions{ $mod } = $module->tag_descriptions;
|
||
|
|
}
|
||
|
|
|
||
|
|
return \%all_tag_descriptions;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _build_last_language {
|
||
|
|
return $ENV{LANGUAGE} // '';
|
||
|
|
}
|
||
|
|
|
||
|
|
###
|
||
|
|
### Instance methods
|
||
|
|
###
|
||
|
|
|
||
|
|
sub data {
|
||
|
|
my ( $self ) = @_;
|
||
|
|
|
||
|
|
if ( !exists $self->{_data} ) {
|
||
|
|
$self->{_data} = $self->_load_data;
|
||
|
|
}
|
||
|
|
|
||
|
|
return $self->{_data};
|
||
|
|
}
|
||
|
|
|
||
|
|
sub all_tag_descriptions {
|
||
|
|
my ( $self ) = @_;
|
||
|
|
|
||
|
|
return $self->{_all_tag_descriptions};
|
||
|
|
}
|
||
|
|
|
||
|
|
sub locale {
|
||
|
|
my ( $self, @args ) = @_;
|
||
|
|
|
||
|
|
if ( @args ) {
|
||
|
|
my $new_locale = shift @args;
|
||
|
|
|
||
|
|
# On some systems gettext takes its locale from setlocale().
|
||
|
|
if ( !defined setlocale( LC_MESSAGES, $new_locale ) ) {
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
|
||
|
|
$self->_last_language( $ENV{LANGUAGE} // '' );
|
||
|
|
|
||
|
|
# On some systems gettext takes its locale from %ENV.
|
||
|
|
$ENV{LC_MESSAGES} = $new_locale;
|
||
|
|
|
||
|
|
# On some systems gettext refuses to switch over to another locale unless
|
||
|
|
# the textdomain is reset.
|
||
|
|
textdomain( 'Zonemaster-Engine' );
|
||
|
|
|
||
|
|
if ( !defined $new_locale || ref $new_locale ne '' ) {
|
||
|
|
croak "locale must be a defined scalar";
|
||
|
|
}
|
||
|
|
|
||
|
|
$self->{_locale} = $new_locale;
|
||
|
|
} ## end if ( @args )
|
||
|
|
|
||
|
|
return $self->{_locale};
|
||
|
|
};
|
||
|
|
|
||
|
|
sub to_string {
|
||
|
|
my ( $self, $entry ) = @_;
|
||
|
|
|
||
|
|
return sprintf( "%7.2f %-9s %s", $entry->timestamp, $entry->level, $self->translate_tag( $entry ) );
|
||
|
|
}
|
||
|
|
|
||
|
|
sub translate_tag {
|
||
|
|
my ( $self, $entry ) = @_;
|
||
|
|
|
||
|
|
return $self->_translate_tag( $entry->module, $entry->tag, $entry->printable_args ) // $entry->string;
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
sub test_case_description {
|
||
|
|
my ( $self, $test_name ) = @_;
|
||
|
|
|
||
|
|
my $module = $test_name;
|
||
|
|
$module =~ s/\d+$//;
|
||
|
|
|
||
|
|
return $self->_translate_tag( $module, uc $test_name, {} ) // $test_name;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _last_language {
|
||
|
|
my $self = shift;
|
||
|
|
|
||
|
|
if ( @_ ) {
|
||
|
|
my $last_language = shift;
|
||
|
|
if ( !defined $last_language || ref $last_language ne '' ) {
|
||
|
|
croak "_last_language must be a defined scalar";
|
||
|
|
}
|
||
|
|
$self->{_last_language} = $last_language;
|
||
|
|
}
|
||
|
|
|
||
|
|
return $self->{_last_language};
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _translate_tag {
|
||
|
|
my ( $self, $module, $tag, $args ) = @_;
|
||
|
|
|
||
|
|
if ( $ENV{LANGUAGE} // '' ne $self->_last_language ) {
|
||
|
|
$self->locale( $self->locale );
|
||
|
|
}
|
||
|
|
|
||
|
|
my $code = $self->all_tag_descriptions->{$module}{$tag};
|
||
|
|
|
||
|
|
if ( $code ) {
|
||
|
|
return $code->( %{$args} );
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
return undef;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
1;
|
||
|
|
|
||
|
|
=head1 NAME
|
||
|
|
|
||
|
|
Zonemaster::Engine::Translator - translation support for Zonemaster
|
||
|
|
|
||
|
|
=head1 SYNOPSIS
|
||
|
|
|
||
|
|
Zonemaster::Engine::Translator->initialize( locale => 'sv_SE.UTF-8' );
|
||
|
|
|
||
|
|
my $trans = Zonemaster::Engine::Translator->instance;
|
||
|
|
say $trans->to_string($entry);
|
||
|
|
|
||
|
|
This is a singleton class.
|
||
|
|
|
||
|
|
The instance of this class requires exclusive control over C<$ENV{LC_MESSAGES}>
|
||
|
|
and the program's underlying LC_MESSAGES.
|
||
|
|
At times it resets gettext's textdomain.
|
||
|
|
On construction it unsets C<$ENV{LC_ALL}> and from then on it must remain unset.
|
||
|
|
|
||
|
|
On systems that support C<$ENV{LANGUAGE}>, this variable overrides the locale()
|
||
|
|
attribute unless the locale() attribute is set to C<"C">.
|
||
|
|
|
||
|
|
=head1 ATTRIBUTES
|
||
|
|
|
||
|
|
=over
|
||
|
|
|
||
|
|
=item locale
|
||
|
|
|
||
|
|
The locale used for localized messages.
|
||
|
|
|
||
|
|
say $translator->locale();
|
||
|
|
if ( !$translator->locale( 'sv_SE.UTF-8' ) ) {
|
||
|
|
say "failed to update locale";
|
||
|
|
}
|
||
|
|
|
||
|
|
The value of this attribute is mirrored in C<$ENV{LC_MESSAGES}>.
|
||
|
|
|
||
|
|
When writing to this attribute, a request is made to update the program's
|
||
|
|
underlying LC_MESSAGES.
|
||
|
|
If this request fails, the attribute value remains unchanged and an empty list
|
||
|
|
is returned.
|
||
|
|
|
||
|
|
As a side effect when successfully updating this attribute gettext's textdomain
|
||
|
|
is reset.
|
||
|
|
|
||
|
|
=item data
|
||
|
|
|
||
|
|
A reference to a hash with translation data. This is unlikely to be useful to
|
||
|
|
end-users.
|
||
|
|
|
||
|
|
=item all_tag_descriptions
|
||
|
|
|
||
|
|
=back
|
||
|
|
|
||
|
|
=head1 METHODS
|
||
|
|
|
||
|
|
=over
|
||
|
|
|
||
|
|
=item initialize(%args)
|
||
|
|
|
||
|
|
Provide initial values for the single instance of this class.
|
||
|
|
|
||
|
|
Zonemaster::Engine::Translator->initialize( locale => 'sv_SE.UTF-8' );
|
||
|
|
|
||
|
|
This method must be called at most once and before the first call to instance().
|
||
|
|
|
||
|
|
=item instance()
|
||
|
|
|
||
|
|
Returns the single instance of this class.
|
||
|
|
|
||
|
|
my $translator = Zonemaster::Engine::Translator->instance;
|
||
|
|
|
||
|
|
If initialize() has not been called prior to the first call to instance(), it
|
||
|
|
is the same as if initialize() had been called without arguments.
|
||
|
|
|
||
|
|
=item new(%args)
|
||
|
|
|
||
|
|
Use of this method is deprecated.
|
||
|
|
|
||
|
|
=over
|
||
|
|
|
||
|
|
=item locale
|
||
|
|
|
||
|
|
If no initial value is provided to the constructor, one is determined by calling
|
||
|
|
setlocale( LC_MESSAGES, "" ).
|
||
|
|
|
||
|
|
=back
|
||
|
|
|
||
|
|
=item to_string($entry)
|
||
|
|
|
||
|
|
Takes a L<Zonemaster::Engine::Logger::Entry> object as its argument and returns a translated string with the timestamp, level, message and arguments in the
|
||
|
|
entry.
|
||
|
|
|
||
|
|
=item translate_tag($entry)
|
||
|
|
|
||
|
|
Takes a L<Zonemaster::Engine::Logger::Entry> object as its argument and returns a translation of its tag and arguments.
|
||
|
|
|
||
|
|
=item test_case_description($testcase)
|
||
|
|
|
||
|
|
Takes a string (test case ID) and returns the translated test case description.
|
||
|
|
|
||
|
|
=item BUILD
|
||
|
|
|
||
|
|
Internal method that's only mentioned here to placate L<Pod::Coverage>.
|
||
|
|
|
||
|
|
=back
|
||
|
|
|
||
|
|
=cut
|