view release on metacpan or  search on metacpan

lib/Locale/Maketext/Gettext/Functions.pm  view on Meta::CPAN

# Locale::Maketext::Gettext::Functions - Functional interface to Locale::Maketext::Gettext

# Copyright (c) 2003-2021 imacat. All rights reserved. This program is free
# software; you can redistribute it and/or modify it under the same terms
# as Perl itself.
# First written: 2003/4/28

package Locale::Maketext::Gettext::Functions;
use 5.008;
use strict;
use warnings;
use base qw(Exporter);
our ($VERSION, @EXPORT, @EXPORT_OK);
$VERSION = 0.14;
@EXPORT = qw(
bindtextdomain textdomain get_handle maketext __ N_
dmaketext pmaketext dpmaketext
reload_text read_mo encoding key_encoding encode_failure
die_for_lookup_failures);
@EXPORT_OK = @EXPORT;
# Prototype declaration
sub bindtextdomain($;$);
sub textdomain(;$);
sub get_handle(@);
sub maketext(@);
sub __(@);
sub N_(@);
sub dmaketext($$@);
sub pmaketext($$@);
sub dpmaketext($$$@);
sub reload_text();
sub encoding(;$);
sub key_encoding(;$);
sub encode_failure(;$);
sub die_for_lookup_failures(;$);
sub _declare_class($);
sub _cat_class(@);
sub _init_textdomain($);
sub _get_langs($$);
sub _get_handle();
sub _get_empty_handle();
sub _reset();
sub _new_rid();
sub _k($);
sub _lang($);

use Encode qw(encode decode from_to FB_DEFAULT);
use File::Spec::Functions qw(catdir catfile);
use Locale::Maketext::Gettext qw(read_mo);
our (%LOCALEDIRS, %RIDS, %CLASSES, %LANGS);
our (%LHS, $_EMPTY, $LH, $DOMAIN, $CATEGORY, $BASE_CLASS, @LANGS, %PARAMS);
our (@SYSTEM_LOCALEDIRS);
%LHS = qw();
# The category is always LC_MESSAGES
$CATEGORY = "LC_MESSAGES";
$BASE_CLASS = "Locale::Maketext::Gettext::_runtime";
# Current language parameters
@LANGS = qw();
@SYSTEM_LOCALEDIRS = @Locale::Maketext::Gettext::SYSTEM_LOCALEDIRS;
%PARAMS = qw();
$PARAMS{"KEY_ENCODING"} = "US-ASCII";
$PARAMS{"ENCODE_FAILURE"} = FB_DEFAULT;
$PARAMS{"DIE_FOR_LOOKUP_FAILURES"} = 0;
# Parameters for random class IDs
our ($RID_LEN, @RID_CHARS);
$RID_LEN = 8;
@RID_CHARS = split //,
    "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz";

# Bind a text domain to a locale directory
sub bindtextdomain($;$) {
    local ($_, %_);
    my ($domain, $LOCALEDIR);
    ($domain, $LOCALEDIR) = @_;
    # Return the current registry
    return (exists $LOCALEDIRS{$domain}? $LOCALEDIRS{$domain}: undef)
        if !defined $LOCALEDIR;
    # Register the locale directory
    $LOCALEDIRS{$domain} = $LOCALEDIR;
    # Reinitialize the text domain
    _init_textdomain($domain);
    # Reset the current language handle
    _get_handle() if defined $DOMAIN && $domain eq $DOMAIN;
    # Return the locale directory
    return $LOCALEDIR;
}

# Set the current text domain
sub textdomain(;$) {
    local ($_, %_);
    my ($new_domain);
    $new_domain = $_[0];
    # Return the current text domain
    return $DOMAIN if !defined $new_domain;
    # Set the current text domain
    $DOMAIN = $new_domain;
    # Reinitialize the text domain
    _init_textdomain($DOMAIN);
    # Reset the current language handle
    _get_handle();
    return $DOMAIN;
}

# Get a language handle
sub get_handle(@) {
    local ($_, %_);
    # Register the current get_handle arguments
    @LANGS = @_;
    # Reset and return the current language handle
    return _get_handle();
}

# Maketext, in its long name
#   Use @ instead of $@ in prototype, so that we can pass @_ to it.
sub maketext(@) {
    return __($_[0], @_[1..$#_]);
}

# Maketext, in its shortcut name
#   Use @ instead of $@ in prototype, so that we can pass @_ to it.
sub __(@) {
    local ($_, %_);
    my ($key, @param, $keyd);
    ($key, @param) = @_;
    # Reset the current language handle if it is not set yet
    _get_handle() if !defined $LH;
    
    # Decode the source text
    $keyd = $key;
    $keyd = decode($PARAMS{"KEY_ENCODING"}, $keyd, $PARAMS{"ENCODE_FAILURE"})
        if exists $PARAMS{"KEY_ENCODING"} && !Encode::is_utf8($key);
    # Maketext
    $_ = $LH->maketext($keyd, @param);
    # Output to the requested encoding
    if (exists $PARAMS{"ENCODING"}) {
        $_ = encode($PARAMS{"ENCODING"}, $_, $PARAMS{"ENCODE_FAILURE"});
    # Pass through the empty/invalid lexicon
    } elsif (   scalar(keys %{$LH->{"Lexicon"}}) == 0
                && exists $PARAMS{"KEY_ENCODING"}
                && !Encode::is_utf8($key)) {
        $_ = encode($PARAMS{"KEY_ENCODING"}, $_, $PARAMS{"ENCODE_FAILURE"});
    }
    
    return $_;
}

# Return the original text untouched, so that it can be cached
#   with xgettext
#   Use @ instead of $@ in prototype, so that we can pass @_ to it.
sub N_(@) {
    # Watch out for this Perl magic! :p
    return $_[0] unless wantarray;
    return @_;
}

# Maketext in another text domain temporarily,
#   an equivalent to dgettext().
sub dmaketext($$@) {
    local ($_, %_);
    my ($domain, $key, @param, $lh0, $domain0, $text);
    ($domain, $key, @param) = @_;
    # Preserve the current status
    ($lh0, $domain0) = ($LH, $DOMAIN);
    # Reinitialize the text domain
    textdomain($domain);
    # Maketext
    $text = maketext($key, @param);
    # Return the current status
    ($LH, $DOMAIN) = ($lh0, $domain0);
    # Return the "made text"
    return $text;
}

# Maketext with context,
#   an equivalent to pgettext().
sub pmaketext($$@) {
    local ($_, %_);
    my ($context, $key, @param);
    ($context, $key, @param) = @_;
    # This is actually a wrapper to the maketext() function
    return maketext("$context\x04$key", @param);
}

# Maketext with context in another text domain temporarily,
#   an equivalent to dpgettext().
sub dpmaketext($$$@) {
    local ($_, %_);
    my ($domain, $context, $key, @param);
    ($domain, $context, $key, @param) = @_;
    # This is actually a wrapper to the dmaketext() function
    return dmaketext($domain, "$context\x04$key", @param);
}

# Purge the lexicon cache
sub reload_text() {
    # reload_text is static.
    Locale::Maketext::Gettext->reload_text;
}

# Set the output encoding
sub encoding(;$) {
    local ($_, %_);
    $_ = $_[0];
    
    # Set the output encoding
    if (@_ > 0) {
        if (defined $_) {
            $PARAMS{"ENCODING"} = $_;
        } else {
            delete $PARAMS{"ENCODING"};

lib/Locale/Maketext/Gettext/Functions.pm  view on Meta::CPAN

        if (exists $LH->{"MO_ENCODING"}) {
            $PARAMS{"ENCODING"} = $LH->{"MO_ENCODING"};
        } else {
            delete $PARAMS{"ENCODING"};
        }
    }
    # We handle the encoding() and key_encoding() ourselves.
    $LH->key_encoding(undef);
    $LH->encoding(undef);
    # Register it
    $LHS{$subclass} = $LH;
    
    return _lang($LH);
}

# Obtain the empty language handle
sub _get_empty_handle() {
    local ($_, %_);
    if (!defined $_EMPTY) {
        $_EMPTY = Locale::Maketext::Gettext::Functions::_EMPTY->get_handle;
        $_EMPTY->key_encoding(undef);
        $_EMPTY->encoding(undef);
    }
    $LH = $_EMPTY;
    $LH->die_for_lookup_failures($PARAMS{"DIE_FOR_LOOKUP_FAILURES"});
    return _lang($LH);
}

# Initialize everything
sub _reset() {
    local ($_, %_);
    
    %LOCALEDIRS = qw();
    undef $LH;
    undef $DOMAIN;
    @LANGS = qw();
    %PARAMS = qw();
    $PARAMS{"KEY_ENCODING"} = "US-ASCII";
    $PARAMS{"ENCODE_FAILURE"} = FB_DEFAULT;
    $PARAMS{"DIE_FOR_LOOKUP_FAILURES"} = 0;
    
    return;
}

# Generate a new random ID
sub _new_rid() {
    local ($_, %_);
    my ($id);
    
    do {
        for ($id = "", $_ = 0; $_ < $RID_LEN; $_++) {
            $id .= $RID_CHARS[int rand scalar @RID_CHARS];
        }
    } while exists $RIDS{$id};
    $RIDS{$id} = 1;
    
    return $id;
}

# Build the key for the domain registry
sub _k($) {
    return join "\n", $LOCALEDIRS{$_[0]}, $CATEGORY, $_[0];
}

# The language from a language handle.  language_tag is not quite sane.
sub _lang($) {
    local ($_, %_);
    $_ = $_[0];
    $_ = ref($_);
    s/^.+:://;
    s/_/-/g;
    return $_;
}

# Public empty lexicon
package Locale::Maketext::Gettext::Functions::_EMPTY;
use 5.008;
use strict;
use warnings;
use base qw(Locale::Maketext::Gettext);
our $VERSION = 0.01;

package Locale::Maketext::Gettext::Functions::_EMPTY::i_default;
use 5.008;
use strict;
use warnings;
use base qw(Locale::Maketext::Gettext);
our $VERSION = 0.01;

return 1;

__END__

=head1 NAME

Locale::Maketext::Gettext::Functions - Functional interface to Locale::Maketext::Gettext

=head1 SYNOPSIS

  use Locale::Maketext::Gettext::Functions;
  bindtextdomain(DOMAIN, LOCALEDIR);
  textdomain(DOMAIN);
  get_handle("de");
  print __("Hello, world!\n");

=head1 DESCRIPTION

Locale::Maketext::Gettext::Functions is a functional
interface to
L<Locale::Maketext::Gettext(3)|Locale::Maketext::Gettext/3> (and
L<Locale::Maketext(3)|Locale::Maketext/3>).  It works exactly the GNU
gettext way.  It plays magic to
L<Locale::Maketext(3)|Locale::Maketext/3> for you.  No more
localization class/subclasses and language handles are required at
all.

The C<maketext>, C<dmaketext>, C<pmaketext> and C<dpmaketext>
functions attempt to translate a text message into the native
language of the user, by looking up the translation in an MO lexicon
file.