File Coverage

blib/lib/Template/Plugin/Gettext.pm

Criterion	Covered	Total	%
statement	225	240	93.7
branch	41	84	48.8
condition	16	51	31.3
subroutine	48	51	94.1
pod	15	16	93.7
total	345	442	78.0

#! /bin/false

# Copyright (C) 2016-2018 Guido Flohr ,
# all rights reserved.

# This program is free software; you can redistribute it and/or modify it
# under the terms of the GNU Library General Public License as published
# by the Free Software Foundation; either version 2, or (at your option)
# any later version.

# This program 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
# Library General Public License for more details.

# You should have received a copy of the GNU Library General Public
# License along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
# USA.

# ABSTRACT: Gettext Support For the Template Toolkit Version 2

package Template::Plugin::Gettext;
$Template::Plugin::Gettext::VERSION = '1.0';
use strict;

use Locale::TextDomain 1.30 qw(com.cantanea.Template-Plugin-Gettext);
use Locale::Messages;
use Locale::Util qw(web_set_locale);
use Encode;

use Cwd qw(abs_path);

use base qw(Template::Plugin);

my %bound_dirs;
my %textdomains;

our @DEFAULT_DIRS;
our @LOCALE_DIRS;

sub __find_domain($);
sub __expand($%);
sub __fixup;

BEGIN {
    foreach my $dir (qw('/usr/share/locale /usr/local/share/locale')) {
        if (-d $dir) {
            push @DEFAULT_DIRS, $dir;
            last;
        }
    }
}

sub new {
    my ($class, $ctx, $textdomain, $language, $charset, @search_dirs) = @_;

    my $self = bless {}, $class;

    $textdomain = 'textdomain' unless defined $textdomain && length $textdomain;
    $charset = 'utf-8' unless defined $charset && length $charset;

    my $template = $ctx->stash->get('component')->name;
    if ('input text' eq $template || 'input file handle' eq $template) {
        my $maybe_template = $ctx->stash->get('gettext_filename');
        $template = $maybe_template
            if defined $maybe_template && length $maybe_template;
    }
    $textdomains{$textdomain}->{$template} = 1;

    unless (exists $bound_dirs{$textdomain}) {
        unless (@search_dirs) {
            @search_dirs = map $_ . '/LocaleData', @INC;
            push @search_dirs, @DEFAULT_DIRS;
        }
        unshift @search_dirs, @LOCALE_DIRS;
        $bound_dirs{$textdomain} = [@search_dirs];
    }

    $self->{__textdomain} = $textdomain;
    $self->{__locale} = web_set_locale $language, $charset if defined $language;

    $ctx->define_filter(gettext => sub {
        my ($context) = @_;

        return sub {
            return __gettext($textdomain, shift);
        };
    }, 1);
    $ctx->define_filter(ngettext => sub {
        my ($context, @args) = @_;
        my $pairs = ref $args[-1] eq 'HASH' ? pop(@args) : {};

        push @args, %$pairs;
        return sub {
            return __ngettext($textdomain, shift, @args);
        };
    }, 1);
    $ctx->define_filter(pgettext => sub {
        my ($context, @args) = @_;
        my $pairs = ref $args[-1] eq 'HASH' ? pop(@args) : {};

        push @args, %$pairs;
        return sub {
            return __pgettext($textdomain, shift, @args);
        };
    }, 1);
    $ctx->define_filter(gettextp => sub {
        my ($context, @args) = @_;
        my $pairs = ref $args[-1] eq 'HASH' ? pop(@args) : {};

        push @args, %$pairs;
        return sub {
            return __gettextp($textdomain, shift, @args);
        };
    }, 1);
    $ctx->define_filter(npgettext => sub {
        my ($context, @args) = @_;
        my $pairs = ref $args[-1] eq 'HASH' ? pop(@args) : {};

        push @args, %$pairs;
        return sub {
            return __npgettext($textdomain, shift, @args);
        };
    }, 1);
    $ctx->define_filter(ngettextp => sub {
        my ($context, @args) = @_;
        my $pairs = ref $args[-1] eq 'HASH' ? pop(@args) : {};

        push @args, %$pairs;
        return sub {
            return __ngettextp($textdomain, shift, @args);
        };
    }, 1);
    $ctx->define_filter(xgettext => sub {
        my ($context, @args) = @_;
        my $pairs = ref $args[-1] eq 'HASH' ? pop(@args) : {};

        push @args, %$pairs;
        return sub {
            return __xgettext($textdomain, shift, @args);
        };
    }, 1);
    $ctx->define_filter(nxgettext => sub {
        my ($context, @args) = @_;
        my $pairs = ref $args[-1] eq 'HASH' ? pop(@args) : {};

        push @args, %$pairs;
        return sub {
            return __nxgettext($textdomain, shift, @args);
        };
    }, 1);
    $ctx->define_filter(pxgettext => sub {
        my ($context, @args) = @_;
        my $pairs = ref $args[-1] eq 'HASH' ? pop(@args) : {};

        push @args, %$pairs;
        return sub {
            return __pxgettext($textdomain, shift, @args);
        };
    }, 1);
    $ctx->define_filter(xgettextp => sub {
        my ($context, @args) = @_;
        my $pairs = ref $args[-1] eq 'HASH' ? pop(@args) : {};

        push @args, %$pairs;
        return sub {
            return __xgettextp($textdomain, shift, @args);
        };
    }, 1);
    $ctx->define_filter(npxgettext => sub {
        my ($context, @args) = @_;
        my $pairs = ref $args[-1] eq 'HASH' ? pop(@args) : {};

        push @args, %$pairs;
        return sub {
            return __npxgettext($textdomain, shift, @args);
        };
    }, 1);
    $ctx->define_filter(nxgettextp => sub {
        my ($context, @args) = @_;
        my $pairs = ref $args[-1] eq 'HASH' ? pop(@args) : {};

        push @args, %$pairs;
        return sub {
            return __nxgettextp($textdomain, shift, @args);
        };
    }, 1);

    return $self;
}

sub __fixup {
    my $trans = $_[-1];

    Encode::_utf8_on($trans);

    return $trans;
}

sub __gettext {
    my ($textdomain, $msgid) = @_;

    local %ENV = %ENV;
    delete $ENV{LANGUAGE};

    __find_domain $textdomain
        if defined $textdomain && exists $bound_dirs{$textdomain};

    return __fixup $msgid, Locale::Messages::dgettext($textdomain => $msgid);
}

sub gettext {
    my ($self, $msgid) = @_;

    return __gettext $self->{__textdomain}, $msgid;
}

sub __ngettext {
    my ($textdomain, $msgid, $msgid_plural, $count) = @_;

    local %ENV = %ENV;
    delete $ENV{LANGUAGE};

    __find_domain $textdomain
        if defined $textdomain && exists $bound_dirs{$textdomain};

    return __fixup $msgid, $msgid_plural, $count,
                   Locale::Messages::dngettext($textdomain => $msgid,
                                               $msgid_plural, $count);
}

sub ngettext {
    my ($self, $msgid, $msgid_plural, $count) = @_;

    return __ngettext $self->{__textdomain}, $msgid, $msgid_plural, $count;
}

sub __pgettext {
    my ($textdomain, $context, $msgid) = @_;

    local %ENV = %ENV;
    delete $ENV{LANGUAGE};

    __find_domain $textdomain
        if defined $textdomain && exists $bound_dirs{$textdomain};

    return __fixup $msgid,
                   Locale::Messages::dpgettext($textdomain => $context, $msgid);
}

sub pgettext {
    my ($self, $context, $msgid) = @_;

    return __pgettext $self->{__textdomain}, $context, $msgid;
}

sub __gettextp {
    my ($textdomain, $msgid, $context) = @_;

    local %ENV = %ENV;
    delete $ENV{LANGUAGE};

    __find_domain $textdomain
        if defined $textdomain && exists $bound_dirs{$textdomain};

    return __fixup $msgid,
                   Locale::Messages::dpgettext($textdomain => $context, $msgid);
}

sub gettextp {
    my ($self, $msgid, $context) = @_;

    return __gettextp $self->{__textdomain}, $msgid, $context;
}

sub __npgettext {
    my ($textdomain, $context, $msgid, $msgid_plural, $count) = @_;

    local %ENV = %ENV;
    delete $ENV{LANGUAGE};

    __find_domain $textdomain
        if defined $textdomain && exists $bound_dirs{$textdomain};

    return __fixup $msgid, $msgid_plural, $count,
                   Locale::Messages::dnpgettext($textdomain, $context, $msgid,
                                                $msgid_plural, $count);
}

sub npgettext {
    my ($self, $context, $msgid, $msgid_plural, $count) = @_;

    return __npgettext $self->{__textdomain}, $context, $msgid, $msgid_plural,
                       $count;
}

sub __ngettextp {
    my ($textdomain, $msgid, $msgid_plural, $count, $context) = @_;

    local %ENV = %ENV;
    delete $ENV{LANGUAGE};

    __find_domain $textdomain
        if defined $textdomain && exists $bound_dirs{$textdomain};

    return __fixup $msgid, $msgid_plural, $count,
                   Locale::Messages::dnpgettext($textdomain => $context, $msgid,
                                                $msgid_plural, $count);
}

sub ngettextp {
    my ($self, $msgid, $msgid_plural, $count, $context) = @_;

    return __ngettextp $self->{__textdomain}, $msgid, $msgid_plural, $count,
                       $context;
}

sub __xgettext {
    my ($textdomain, $msgid, %vars) = @_;

    local %ENV = %ENV;
    delete $ENV{LANGUAGE};

    __find_domain $textdomain
        if defined $textdomain && exists $bound_dirs{$textdomain};

    return __expand((__fixup $msgid,
                             Locale::Messages::dgettext($textdomain => $msgid)),                    %vars);
}

sub xgettext {
    my ($self, $msgid, @args) = @_;

    my $pairs = ref $args[-1] eq 'HASH' ? pop(@args) : {};
    push @args, %$pairs;

    return __xgettext $self->{__textdomain}, $msgid, @args;
}

sub __nxgettext {
    my ($textdomain, $msgid, $msgid_plural, $count, %vars) = @_;

    local %ENV = %ENV;
    delete $ENV{LANGUAGE};

    __find_domain $textdomain
        if defined $textdomain && exists $bound_dirs{$textdomain};

    return __expand((__fixup $msgid, $msgid_plural, $count,
                             Locale::Messages::dngettext($textdomain => $msgid,
                                                         $msgid_plural,
                                                         $count)),
                    %vars);
}

sub nxgettext {
    my ($self, $msgid, $msgid_plural, $count, @args) = @_;

    my $pairs = ref $args[-1] eq 'HASH' ? pop(@args) : {};
    push @args, %$pairs;

    return __nxgettext $self->{__textdomain}, $msgid, $msgid_plural, $count,
                       @args;
}

sub __pxgettext {
    my ($textdomain, $context, $msgid, %vars) = @_;

    local %ENV = %ENV;
    delete $ENV{LANGUAGE};

    __find_domain $textdomain
        if defined $textdomain && exists $bound_dirs{$textdomain};

    return __expand((__fixup $msgid,
                             Locale::Messages::dpgettext($textdomain => $context,
                                                         $msgid)),
                    %vars);
}

sub pxgettext {
    my ($self, $context, @args) = @_;

    my $pairs = ref $args[-1] eq 'HASH' ? pop(@args) : {};
    push @args, %$pairs;

    return __pxgettext $self->{__textdomain}, $context, @args;
}

sub __xgettextp {
    my ($textdomain, $msgid, $context, %vars) = @_;

    local %ENV = %ENV;
    delete $ENV{LANGUAGE};

    __find_domain $textdomain
        if defined $textdomain && exists $bound_dirs{$textdomain};

    return __expand((__fixup $msgid,
                             Locale::Messages::dpgettext($textdomain => $context,
                                                         $msgid)),
                    %vars);
}

sub xgettextp {
    my ($self, $msgid, @args) = @_;

    my $pairs = ref $args[-1] eq 'HASH' ? pop(@args) : {};
    push @args, %$pairs;

    return __xgettextp $self->{__textdomain}, $msgid, @args;
}

sub __npxgettext {
    my ($textdomain, $context, $msgid, $msgid_plural, $count, %vars) = @_;

    local %ENV = %ENV;
    delete $ENV{LANGUAGE};

    __find_domain $textdomain
        if defined $textdomain && exists $bound_dirs{$textdomain};

    return __expand((__fixup $msgid, $msgid_plural, $count,
                             Locale::Messages::dnpgettext($textdomain => $context,
                                                          $msgid, $msgid_plural,
                                                          $count)),
                    %vars);
}

sub npxgettext {
    my ($self, $context, @args) = @_;

    my $pairs = ref $args[-1] eq 'HASH' ? pop(@args) : {};
    push @args, %$pairs;

    return __npxgettext $self->{__textdomain}, $context, @args;
}

sub __nxgettextp {
    my ($textdomain, $msgid, $msgid_plural, $count, $context, %vars) = @_;

    local %ENV = %ENV;
    delete $ENV{LANGUAGE};

    __find_domain $textdomain
        if defined $textdomain && exists $bound_dirs{$textdomain};

    return __expand((__fixup $msgid, $msgid_plural, $count,
                             Locale::Messages::dnpgettext($textdomain => $context,
                                                          $msgid, $msgid_plural,
                                                          $count)),
                    %vars);
}

sub nxgettextp {
    my ($self, $msgid, @args) = @_;

    my $pairs = ref $args[-1] eq 'HASH' ? pop(@args) : {};
    push @args, %$pairs;

    return __nxgettextp $self->{__textdomain}, $msgid, @args;
}

sub debug_locale {
    shift->{__locale};
}

sub __expand($%) {
    my ($str, %vars) = @_;

    my $re = join '|', map { quotemeta } keys %vars;
    $str =~ s/\{($re)\}/exists $vars{$1} ?
        (defined $vars{$1} ? $vars{$1} : '') : "{$1}"/ge;

    return $str;
}

sub __find_domain($) {
    my ($domain) = @_;

    my $try_dirs = $bound_dirs{$domain};

    if (defined $try_dirs) {
        my $found_dir = '';

        TRYDIR: foreach my $dir (map {abs_path $_} grep { -d $_ } @$try_dirs) {
            # Is there a message catalog?

            local *DIR;
            if (opendir DIR, $dir) {
                 my @files = map { "$dir/$_/LC_MESSAGES/$domain.mo" }
                             grep { ! /^\.\.?$/ } readdir DIR;
                 foreach my $file (@files) {
                     if (-f $file || -l $file) {
                         $found_dir = $dir;
                         last TRYDIR;
                     }
                 }
            }
        }

        # If $found_dir is undef, the default search directories are
        # used.
        Locale::Messages::bindtextdomain($domain => $found_dir);
    }

    delete $bound_dirs{$domain};

    return 1;
}

sub textdomains {
    return %textdomains;
}

sub resetTextdomains {
    undef %textdomains;
}

1;