File Coverage

blib/lib/Locale/Maketext/Gettext.pm

Criterion	Covered	Total	%
statement	259	268	96.6
branch	93	124	75.0
condition	18	27	66.6
subroutine	25	25	100.0
pod	12	14	85.7
total	407	458	88.8

# Locale::Maketext::Gettext - Joins the gettext and Maketext frameworks

# Copyright (c) 2003-2019 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-04-23

package Locale::Maketext::Gettext;
use 5.008;
use strict;
use warnings;
use base qw(Locale::Maketext Exporter);
use vars qw($VERSION @ISA %Lexicon @EXPORT @EXPORT_OK);
$VERSION = 1.30;
@EXPORT = qw(read_mo);
@EXPORT_OK = @EXPORT;
# Prototype declaration
sub read_mo($);

use Encode qw(encode decode FB_DEFAULT);
use File::Spec::Functions qw(catfile);
no strict qw(refs);

use vars qw(%CACHE $REREAD_MO $MO_FILE);
%CACHE = qw();
$REREAD_MO = 0;
$MO_FILE = "";
use vars qw(@SYSTEM_LOCALEDIRS);
@SYSTEM_LOCALEDIRS = qw(/usr/share/locale /usr/lib/locale
    /usr/local/share/locale /usr/local/lib/locale);

# encoding: Set or retrieve the output encoding
sub encoding : method {
    local ($_, %_);
    my $self;
    ($self, $_) = @_;

    # This is not a static method
    return if ref($self) eq "";

    # Set the output encoding
    if (@_ > 1) {
        if (defined $_) {
            $self->{"ENCODING"} = $_;
        } else {
            delete $self->{"ENCODING"};
        }
        $self->{"USERSET_ENCODING"} = $_;
    }

    # Return the encoding
    return exists $self->{"ENCODING"}? $self->{"ENCODING"}: undef;
}

# key_encoding: Specify the encoding used in the keys
sub key_encoding : method {
    local ($_, %_);
    my $self;
    ($self, $_) = @_;

    # This is not a static method
    return if ref($self) eq "";

    # Set the encoding used in the keys
    if (@_ > 1) {
        if (defined $_) {
            $self->{"KEY_ENCODING"} = $_;
        } else {
            delete $self->{"KEY_ENCODING"};
        }
    }

    # Return the encoding
    return exists $self->{"KEY_ENCODING"}? $self->{"KEY_ENCODING"}: undef;
}

# new: Initialize the language handler
sub new : method {
    local ($_, %_);
    my ($self, $class);
    $class = ref($_[0]) || $_[0];
    $self = bless {}, $class;
    $self->subclass_init;
    $self->init;
    return $self;
}

# subclass_init: Initialize at the subclass level, so that it can be
#                inherited by calling $self->SUPER:subclass_init
sub subclass_init : method {
    local ($_, %_);
    my ($self, $class);
    $self = $_[0];
    $class = ref($self);
    # Initialize the instance lexicon
    $self->{"Lexicon"} = {};
    # Initialize the LOCALEDIRS registry
    $self->{"LOCALEDIRS"} = {};
    # Initialize the MO timestamp
    $self->{"REREAD_MO"} = $REREAD_MO;
    # Initialize the DIE_FOR_LOOKUP_FAILURES setting
    $self->{"DIE_FOR_LOOKUP_FAILURES"} = 0;
    $self->SUPER::fail_with($self->can("failure_handler_auto"));
    # Initialize the ENCODE_FAILURE setting
    $self->{"ENCODE_FAILURE"} = FB_DEFAULT;
    # Initialize the MO_FILE value of this instance
    $self->{"MO_FILE"} = "";
    ${"$class\::MO_FILE"} = "" if !defined ${"$class\::MO_FILE"};
    # Find the locale name, for this subclass
    $self->{"LOCALE"} = $class;
    $self->{"LOCALE"} =~ s/^.*:://;
    $self->{"LOCALE"} =~ s/(_)(.*)$/$1 . uc $2/e;
    # Map i_default to C
    $self->{"LOCALE"} = "C" if $self->{"LOCALE"} eq "i_default";
    # Set the category.  Currently this is always LC_MESSAGES
    $self->{"CATEGORY"} = "LC_MESSAGES";
    # Default key encoding is US-ASCII
    $self->{"KEY_ENCODING"} = "US-ASCII";
    return;
}

# bindtextdomain: Bind a text domain to a locale directory
sub bindtextdomain : method {
    local ($_, %_);
    my ($self, $DOMAIN, $LOCALEDIR);
    ($self, $DOMAIN, $LOCALEDIR) = @_;

    # This is not a static method
    return if ref($self) eq "";

    # Return null for this rare case
    return if   !defined $LOCALEDIR
                && !exists ${$self->{"LOCALEDIRS"}}{$DOMAIN};

    # Register the DOMAIN and its LOCALEDIR
    ${$self->{"LOCALEDIRS"}}{$DOMAIN} = $LOCALEDIR if defined $LOCALEDIR;

    # Return the registry
    return ${$self->{"LOCALEDIRS"}}{$DOMAIN};
}

# textdomain: Set the current text domain
sub textdomain : method {
    local ($_, %_);
    my ($self, $class, $DOMAIN, $LOCALEDIR, $mo_file);
    ($self, $DOMAIN) = @_;

    # This is not a static method
    return if ref($self) eq "";
    # Find the class name
    $class = ref($self);

    # Return the current domain
    return $self->{"DOMAIN"} if !defined $DOMAIN;

    # Set the timestamp of this read in this instance
    $self->{"REREAD_MO"} = $REREAD_MO;
    # Set the current domain
    $self->{"DOMAIN"} = $DOMAIN;

    # Clear it
    $self->{"Lexicon"} = {};
    %{"$class\::Lexicon"} = qw();
    $self->{"MO_FILE"} = "";
    ${"$class\::MO_FILE"} = "";

    # The format is "{LOCALEDIR}/{LOCALE}/{CATEGORY}/{DOMAIN}.mo"
    # Search the system locale directories if the domain was not
    # registered yet
    if (!exists ${$self->{"LOCALEDIRS"}}{$DOMAIN}) {
        undef $mo_file;
        foreach $LOCALEDIR (@SYSTEM_LOCALEDIRS) {
            $_ = catfile($LOCALEDIR, $self->{"LOCALE"},
                $self->{"CATEGORY"}, "$DOMAIN.mo");
            if (-f $_ && -r $_) {
                $mo_file = $_;
                last;
            }
        }
        # Not found at last
        return $DOMAIN if !defined $mo_file;

    # This domain was registered
    } else {
        $mo_file = catfile(${$self->{"LOCALEDIRS"}}{$DOMAIN},
            $self->{"LOCALE"}, $self->{"CATEGORY"}, "$DOMAIN.mo");
    }

    # Record it
    ${"$class\::MO_FILE"} = $mo_file;
    $self->{"MO_FILE"} = $mo_file;

    # Read the MO file
    # Cached
    if (!$self->_is_using_cache($mo_file)) {
        my ($enc, @stats, $mtime, $size);
        # Read it
        %_ = read_mo($mo_file);

        # Successfully read
        if (scalar(keys %_) > 0) {
            # Decode it
            # Find the encoding of that MO file
            if ($_{""} =~ /^Content-Type: text\/plain; charset=(.*)$/im) {
                $enc = $1;
            # Default to US-ASCII
            } else {
                $enc = "US-ASCII";
            }
            # Set the current encoding to the encoding of the MO file
            $_{$_} = decode($enc, $_{$_}) foreach keys %_;
        }

        # Cache them
        @stats = stat $mo_file;
        if (@stats > 0) {
            ($mtime, $size) = @stats[9,7];
        } else {
            ($mtime, $size) = (undef, undef);
        }
        $CACHE{$mo_file} = {
                "Lexicon"   => {%_},
                "encoding"  => $enc,
                "mtime"     => $mtime,
                "size"      => $size,
            };
    }

    # Respect the existing output encoding
    if (defined $CACHE{$mo_file}->{"encoding"}) {
        $self->{"MO_ENCODING"} = $CACHE{$mo_file}->{"encoding"};
    } else {
        delete $self->{"MO_ENCODING"};
    }
    # Respect the MO file encoding unless there is a user preferrence
    if (!exists $self->{"USERSET_ENCODING"}) {
        if (exists $self->{"MO_ENCODING"}) {
            $self->{"ENCODING"} = $self->{"MO_ENCODING"};
        } else {
            delete $self->{"ENCODING"};
        }
    }
    $self->{"Lexicon"} = $CACHE{$mo_file}->{"Lexicon"};
    %{"$class\::Lexicon"} = %{$CACHE{$mo_file}->{"Lexicon"}};
    $self->clear_isa_scan;

    return $DOMAIN;
}

# _is_using_cache: Return whether we are using our cache.
sub _is_using_cache : method {
    local ($_, %_);
    my ($self, $mo_file, @stats, $mtime, $size);
    ($self, $mo_file) = @_;

    # NO if we do not have such a cache.
    return undef unless exists $CACHE{$mo_file};

    @stats = stat $mo_file;
    # The MO file does not exist previously.
    if (!defined $CACHE{$mo_file}->{"mtime"}
        || !defined $CACHE{$mo_file}->{"size"}) {
        # Use the cache if the MO file still does not exist.
        return (@stats == 0);

    # The MO file exists previously.
    } else {
        # Use the cache if the MO file did not change.
        ($mtime, $size) = @stats[9,7];
        return $mtime == $CACHE{$mo_file}->{"mtime"}
                && $size == $CACHE{$mo_file}->{"size"};
    }
}

# maketext: Encode after maketext
sub maketext : method {
    local ($_, %_);
    my ($self, $key, @param, $class, $keyd);
    ($self, $key, @param) = @_;

    # This is not a static method - NOW
    return if ref($self) eq "";
    # Find the class name
    $class = ref($self);

    # MO file should be re-read
    if ($self->{"REREAD_MO"} < $REREAD_MO) {
        $self->{"REREAD_MO"} = $REREAD_MO;
        defined($_ = $self->textdomain) and $self->textdomain($_);
    }

    # If the instance lexicon is changed.
    # Maketext uses a class lexicon.  We have to copy the instance
    #   lexicon into the class lexicon.  This is slow.  Mass memory
    #   copy sucks.  Avoid create several language handles for a
    #   single localization subclass whenever possible.
    # Maketext uses class lexicon in order to track the inheritance.
    #   It is hard to change it.
    if (${"$class\::MO_FILE"} ne $self->{"MO_FILE"}) {
        ${"$class\::MO_FILE"} = $self->{"MO_FILE"};
        %{"$class\::Lexicon"} = %{$self->{"Lexicon"}};
    }

    # Decode the source text
    $keyd = $key;
    $keyd = decode($self->{"KEY_ENCODING"}, $keyd, $self->{"ENCODE_FAILURE"})
        if exists $self->{"KEY_ENCODING"} && !Encode::is_utf8($key);
    # Maketext
    $_ = $self->SUPER::maketext($keyd, @param);
    # Output to the requested encoding
    if (exists $self->{"ENCODING"}) {
        $_ = encode($self->{"ENCODING"}, $_, $self->{"ENCODE_FAILURE"});
    # Pass through the empty/invalid lexicon
    } elsif (   scalar(keys %{$self->{"Lexicon"}}) == 0
                && exists $self->{"KEY_ENCODING"}
                && !Encode::is_utf8($key)) {
        $_ = encode($self->{"KEY_ENCODING"}, $_, $self->{"ENCODE_FAILURE"});
    }

    return $_;
}

# pmaketext: Maketext with context
sub pmaketext : method {
    local ($_, %_);
    my ($self, $ctxt, $key, @param);
    ($self, $ctxt, $key, @param) = @_;
    # This is not a static method - NOW
    return if ref($self) eq "";
    # This is actually a wrapper to the maketext() method
    return $self->maketext("$ctxt\x04$key", @param);
}

# read_mo: Subroutine to read and parse the MO file
#          Refer to gettext documentation section 8.3
sub read_mo($) {
    local ($_, %_);
    my ($mo_file, $len, $FH, $content, $tmpl);
    $mo_file = $_[0];

    # Avild being stupid
    return unless -f $mo_file && -r $mo_file;
    # Read the MO file
    $len = (stat $mo_file)[7];
    open $FH, $mo_file   or return;  # GNU gettext never fails!
    binmode $FH;
    defined($_ = read $FH, $content, $len)
                        or return;
    close $FH           or return;

    # Find the byte order of the MO file creator
    $_ = substr($content, 0, 4);
    # Little endian
    if ($_ eq "\xde\x12\x04\x95") {
    	$tmpl = "V";
    # Big endian
    } elsif ($_ eq "\x95\x04\x12\xde") {
        $tmpl = "N";
    # Wrong magic number.  Not a valid MO file.
    } else {
        return;
    }

    # Check the MO format revision number
    $_ = unpack $tmpl, substr($content, 4, 4);
    # There is only one revision now: revision 0.
    return if $_ > 0;

    my ($num, $offo, $offt);
    # Number of messages
    $num = unpack $tmpl, substr($content, 8, 4);
    # Offset to the beginning of the original messages
    $offo = unpack $tmpl, substr($content, 12, 4);
    # Offset to the beginning of the translated messages
    $offt = unpack $tmpl, substr($content, 16, 4);
    %_ = qw();
    for ($_ = 0; $_ < $num; $_++) {
        my ($len, $off, $stro, $strt);
        # The first word is the length of the message
        $len = unpack $tmpl, substr($content, $offo+$_*8, 4);
        # The second word is the offset of the message
        $off = unpack $tmpl, substr($content, $offo+$_*8+4, 4);
        # Original message
        $stro = substr($content, $off, $len);

        # The first word is the length of the message
        $len = unpack $tmpl, substr($content, $offt+$_*8, 4);
        # The second word is the offset of the message
        $off = unpack $tmpl, substr($content, $offt+$_*8+4, 4);
        # Translated message
        $strt = substr($content, $off, $len);

        # Hash it
        $_{$stro} = $strt;
    }

    return %_;
}

# reload_text: Method to purge the lexicon cache
sub reload_text : method {
    local ($_, %_);

    # Purge the text cache
    %CACHE = qw();
    $REREAD_MO = time;

    return;
}

# fail_with: A wrapper to the fail_with() of Locale::Maketext, in order
#   to record the preferred failure handler of the user, so that
#   die_for_lookup_failures() knows where to return to.
sub fail_with : method {
    local ($_, %_);
    my $self;
    ($self, $_) = @_;

    # This is not a static method
    return if ref($self) eq "";

    # Set the current setting
    if (@_ > 1) {
        if (defined $_) {
            $self->{"USERSET_FAIL"} = $_;
            $self->SUPER::fail_with($_) if $self->{"DIE_FOR_LOOKUP_FAILURES"};
        } else {
            delete $self->{"USERSET_FAIL"};
            delete $self->{"fail"} if $self->{"DIE_FOR_LOOKUP_FAILURES"};
        }
    }

    # Return the current setting
    return exists $self->{"USERSET_FAIL"}? $self->{"USERSET_FAIL"}: undef;
}

# die_for_lookup_failures: Whether we should die for lookup failure
#   The default is no.  GNU gettext never fails.
sub die_for_lookup_failures : method {
    local ($_, %_);
    my $self;
    ($self, $_) = @_;

    # This is not a static method
    return if ref($self) eq "";

    # Set the current setting
    if (@_ > 1) {
        if ($_) {
            $self->{"DIE_FOR_LOOKUP_FAILURES"} = 1;
            if (exists $self->{"USERSET_FAIL"}) {
                $self->{"fail"} = $self->{"USERSET_FAIL"};
            } else {
                delete $self->{"fail"};
            }
        } else {
            $self->SUPER::fail_with($self->can("failure_handler_auto"));
            $self->{"DIE_FOR_LOOKUP_FAILURES"} = 0;
        }
    }

    # Return the current setting
    return exists $self->{"DIE_FOR_LOOKUP_FAILURES"}?
        $self->{"DIE_FOR_LOOKUP_FAILURES"}: undef;
}

# encode_failure: What to do if the text is out of your output encoding
#   Refer to Encode on possible values of this check
sub encode_failure : method {
    local ($_, %_);
    my $self;
    ($self, $_) = @_;

    # This is not a static method
    return if ref($self) eq "";

    # Specify the action used in the keys
    $self->{"ENCODE_FAILURE"} = $_ if @_ > 1;

    # Return the encoding
    return $self->{"ENCODE_FAILURE"} if exists $self->{"ENCODE_FAILURE"};
    return undef;
}

# failure_handler_auto: Our local version of failure_handler_auto(),
#   Copied and rewritten from Locale::Maketext, with bug#33938 patch applied.
#   See http://rt.perl.org/rt3//Public/Bug/Display.html?id=33938
sub failure_handler_auto : method {
    local ($_, %_);
    my ($self, $key, @param, $r);
    ($self, $key, @param) = @_;

    # This is not a static method
    return if ref($self) eq "";

    # Remove the context
    # We assume there is no one using EOF either in the context or message.
    # That does not work in GNU gettext, anyway.
    $key =~ s/^[^\x04]*\x04//;

    $self->{"failure_lex"} = {} if !exists $self->{"failure_lex"};
    ${$self->{"failure_lex"}}{$key} = $self->_compile($key)
        if !exists ${$self->{"failure_lex"}}{$key};
    $_ = ${$self->{"failure_lex"}}{$key};

    # A scalar result
    return $$_ if ref($_) eq "SCALAR";
    return $_ unless ref($_) eq "CODE";
    # A compiled subroutine
    {
        local $SIG{"__DIE__"};
        $r = eval {
            $_ = &$_($self, @param);
            return 1;
        };
    }

    # If we make it here, there was an exception thrown in the
    #  call to $value, and so scream:
    if (!defined $r) {
        $_ = $@;
        # pretty up the error message
        s<\s+at\s+\(eval\s+\d+\)\s+line\s+(\d+)\.?\n?>
            <\n in bracket code [compiled line $1],>s;
        Carp::croak "Error in maketexting \"$key\":\n$_ as used";
        return;
    }

    # OK
    return $_;
}

return 1;

__END__