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

  package MyPackage::L10N;
  use base qw(Locale::Maketext::Gettext);
  return 1;

  use MyPackage::L10N;
  $LH = MyPackage::L10N->get_handle or die "What language?";
  $LH->bindtextdomain("mypackage", "/home/user/locale");
  $LH->textdomain("mypackage");
  $LH->maketext("Hello, world!!");

  # Change the output encoding
  $LH->encoding("UTF-8");
  # Stick with the Maketext behavior on lookup failures
  $LH->die_for_lookup_failures(1);
  # Flush the MO file cache and re-read your updated MO files
  $LH->reload_text;
  # Set the encoding of your maketext keys, if not in English
  $LH->key_encoding("Big5");
  # Set the action when encode fails
  $LH->encode_failure(Encode::FB_HTMLCREF);

  use Locale::Maketext::Gettext;
  %Lexicon = read_mo($MOfile);

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

# Copyright (c) 2003-2009 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.28;
@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(%Lexicons %ENCODINGS $REREAD_MO $MOFILE);
$REREAD_MO = 0;
$MOFILE = "";
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 MOFILE value of this instance
    $self->{"MOFILE"} = "";
    ${"$class\::MOFILE"} = "" if !defined ${"$class\::MOFILE"};
    # 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, $MOfile);
    ($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->{"MOFILE"} = "";
    ${"$class\::MOFILE"} = "";
    
    # 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 $MOfile;
        foreach $LOCALEDIR (@SYSTEM_LOCALEDIRS) {
            $_ = catfile($LOCALEDIR, $self->{"LOCALE"},
                $self->{"CATEGORY"}, "$DOMAIN.mo");
            if (-f $_ && -r $_) {
                $MOfile = $_;
                last;
            }
        }
        # Not found at last
        return $DOMAIN if !defined $MOfile;
    
    # This domain was registered
    } else {
        $MOfile = catfile(${$self->{"LOCALEDIRS"}}{$DOMAIN},
            $self->{"LOCALE"}, $self->{"CATEGORY"}, "$DOMAIN.mo");
    }
    
    # Record it
    ${"$class\::MOFILE"} = $MOfile;
    $self->{"MOFILE"} = $MOfile;
    
    # Read the MO file
    # Cached
    if (!exists $ENCODINGS{$MOfile} || !exists $Lexicons{$MOfile}) {
        my $enc;
        # Read it
        %_ = read_mo($MOfile);
        
        # 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
        $Lexicons{$MOfile} = \%_;
        $ENCODINGS{$MOfile} = $enc;
    }
    
    # Respect the existing output encoding
    if (defined $ENCODINGS{$MOfile}) {
        $self->{"MO_ENCODING"} = $ENCODINGS{$MOfile};
    } 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"} = $Lexicons{$MOfile};
    %{"$class\::Lexicon"} = %{$Lexicons{$MOfile}};
    $self->clear_isa_scan;
    
    return $DOMAIN;
}

# 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\::MOFILE"} ne $self->{"MOFILE"}) {
        ${"$class\::MOFILE"} = $self->{"MOFILE"};
        %{"$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 ($MOfile, $len, $FH, $content, $tmpl);
    $MOfile = $_[0];
    
    # Avild being stupid
    return unless -f $MOfile && -r $MOfile;
    # Read the MO file
    $len = (stat $MOfile)[7];
    open $FH, $MOfile   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
    %Lexicons = qw();
    %ENCODINGS = 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__