File Coverage

blib/lib/Locale/TextDomain.pm

Criterion	Covered	Total	%
statement	72	138	52.1
branch	13	46	28.2
condition	5	36	13.8
subroutine	18	34	52.9
pod	7	7	100.0
total	115	261	44.0

#! /bin/false

# vim: set autoindent shiftwidth=4 tabstop=4:

# High-level interface to Perl i18n.
# Copyright (C) 2002-2017 Guido Flohr ,
# all rights reserved.

# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 of the License, 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 General Public License for more details.

# You should have received a copy of the GNU General Public License
# along with this program.  If not, see .

package __TiedTextDomain;

use strict;

sub TIEHASH
{
    my ($class, $function) = @_;
    bless {
        __function => $function,
    }, $class;
}

sub FETCH
{
    my ($self, $msg) = @_;

    &{$self->{__function}} ($msg);
}

sub FIRSTKEY
{
    my $self = shift;
    my $reset_iterator = keys %$self;
    return scalar each %$self;
}

sub NEXTKEY
{
    my $self = shift;
    return scalar each %$self;
}

sub CLEAR {}
sub STORE {}
sub DELETE {}

1;

package Locale::TextDomain;

use strict;

use Locale::Messages qw (textdomain bindtextdomain dgettext dngettext dpgettext dnpgettext);
use Cwd qw (abs_path);

use vars qw ($VERSION);

$VERSION = '1.32';

require Exporter;

use vars qw (@ISA @EXPORT %__ $__);

@ISA = ('Exporter');
@EXPORT = qw (__ __x __n __nx __xn __p __px __np __npx $__ %__
              N__ N__n N__p N__np);

my %textdomains = ();
my %bound_dirs = ();
my @default_dirs = ();

sub __ ($);

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

BEGIN {
    # Tie the hash to gettext().
    tie %__, '__TiedTextDomain', \&__tied_gettext;
    $__ = \%__;

	# Add default search directories, but only if they exist.
	for my $dir (qw (/usr/share/locale /usr/local/share/locale)) {
        if (-d $dir) {
            @default_dirs = ($dir);
            last;
        }
    }
}

# Class methods.
sub keywords {
    join ' ', (
        '--keyword=__',
        '--keyword=%__',
        '--keyword=$__',
        '--keyword=__x',
        '--keyword=__n:1,2',
        '--keyword=__nx:1,2',
        '--keyword=__xn:1,2',
        '--keyword=__p:1c,2',
        '--keyword=__px:1c,2',
        '--keyword=__np:1c,2,3',
        '--keyword=__npx:1c,2,3',
        '--keyword=N__',
        '--keyword=N__n:1,2',
        '--keyword=N__p:1c,2',
        '--keyword=N__np:1c,2,3',
    );
}

sub flags {
    join ' ', (
        '--flag=__:1:pass-perl-format',
        '--flag=%__:1:pass-perl-format',
        '--flag=$__:1:pass-perl-format',
        '--flag=__x:1:perl-brace-format',
        '--flag=__x:1:pass-perl-format',
        '--flag=__n:1:pass-perl-format',
        '--flag=__n:2:pass-perl-format',
        '--flag=__nx:1:perl-brace-format',
        '--flag=__nx:1:pass-perl-format',
        '--flag=__nx:2:perl-brace-format',
        '--flag=__nx:2:pass-perl-format',
        '--flag=__xn:1:perl-brace-format',
        '--flag=__xn:1:pass-perl-format',
        '--flag=__xn:2:perl-brace-format',
        '--flag=__xn:2:pass-perl-format',
        '--flag=__p:2:pass-perl-format',
        '--flag=__px:2:perl-brace-format',
        '--flag=__px:2:pass-perl-format',
        '--flag=__np:2:pass-perl-format',
        '--flag=__np:3:pass-perl-format',
        '--flag=__npx:2:perl-brace-format',
        '--flag=__npx:2:pass-perl-format',
        '--flag=__npx:3:perl-brace-format',
        '--flag=__npx:3:pass-perl-format',
        '--flag=N__:1:pass-perl-format',
        '--flag=N__n:1:pass-perl-format',
        '--flag=N__n:2:pass-perl-format',
        '--flag=N__p:2:pass-perl-format',
        '--flag=N__np:2:pass-perl-format',
        '--flag=N__np:3:pass-perl-format',
    );
}

sub options {
    my ($class) = @_;

    join ' ', $class->keywords, $class->flags;
}

# Normal gettext.
sub __ ($)
{
    my $msgid = shift;

    my $package = caller;

    my $textdomain = $textdomains{$package};

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

    return dgettext $textdomain => $msgid;
}

# Called from tied hash.
sub __tied_gettext ($$)
{
    my ($msgid) = @_;

    my ($package) = caller (1);

    my $textdomain = $textdomains{$package};
    unless (defined $textdomain) {
		my ($maybe_package, $filename, $line) = caller (2);
		if (exists $textdomains{$maybe_package}) {
			warn <
Probable use of \$__ or \%__ where __() should be used at $filename:$line.
EOF
		}
	}
    __find_domain $textdomain if
		defined $textdomain && defined $bound_dirs{$textdomain};

    return dgettext $textdomain => $msgid;
}

# With interpolation.
sub __x ($@)
{
    my ($msgid, %vars) = @_;

    my $package = caller;

    my $textdomain = $textdomains{$package};

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

    return __expand ((dgettext $textdomain => $msgid), %vars);
}

# Plural.
sub __n ($$$)
{
    my ($msgid, $msgid_plural, $count) = @_;

    my $package = caller;

    my $textdomain = $textdomains{$package};

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

    return dngettext $textdomain, $msgid, $msgid_plural, $count;
}

# Plural with interpolation.
sub __nx ($$$@)
{
    my ($msgid, $msgid_plural, $count, %args) = @_;

    my $package = caller;

    my $textdomain = $textdomains{$package};

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

    return __expand ((dngettext $textdomain, $msgid, $msgid_plural, $count),
					 %args);
}

# Plural with interpolation.
sub __xn ($$$@)
{
    my ($msgid, $msgid_plural, $count, %args) = @_;

    my $package = caller;

    my $textdomain = $textdomains{$package};

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

    return __expand ((dngettext $textdomain, $msgid, $msgid_plural, $count),
					 %args);
}

# Context. (p is for particular or special)
sub __p ($$)
{
    my $msgctxt = shift;
    my $msgid = shift;

    my $package = caller;

    my $textdomain = $textdomains{$package};

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

    return dpgettext $textdomain => $msgctxt, $msgid;
}

# With interpolation.
sub __px ($$@)
{
    my ($msgctxt, $msgid, %vars) = @_;

    my $package = caller;

    my $textdomain = $textdomains{$package};

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

    return __expand ((dpgettext $textdomain => $msgctxt, $msgid), %vars);
}

# Context + Plural.
sub __np ($$$$)
{
    my ($msgctxt, $msgid, $msgid_plural, $count) = @_;

    my $package = caller;

    my $textdomain = $textdomains{$package};

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

    return dnpgettext $textdomain, $msgctxt, $msgid, $msgid_plural, $count;
}

# Plural with interpolation.
sub __npx ($$$$@)
{
    my ($msgctxt, $msgid, $msgid_plural, $count, %args) = @_;

    my $package = caller;

    my $textdomain = $textdomains{$package};

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

    return __expand ((dnpgettext $textdomain, $msgctxt, $msgid, $msgid_plural, $count),
					 %args);
}

# Dummy functions for string marking.
sub N__($)
{
    return shift;
}

sub N__n($$$)
{
    return @_;
}

sub N__p($$) {
    return @_;
}

sub N__np($$$$) {
    return @_;
}

sub import
{
    my ($self, $textdomain, @search_dirs) = @_;

    # Check our caller.
    my $package = caller;
    return if exists $textdomains{$package};

    # Was a textdomain specified?
	$textdomain = textdomain unless defined $textdomain && length $textdomain;

    # Remember the textdomain of that package.
    $textdomains{$package} = $textdomain;

    # Remember that we still have to bind that textdomain to
    # a directory.
    unless (exists $bound_dirs{$textdomain}) {
		unless (@search_dirs) {
			@search_dirs = ((map $_ . '/LocaleData', @INC), @default_dirs)
				unless @search_dirs;
			if (my $share = eval {
				require File::ShareDir;
				File::ShareDir::dist_dir ($textdomain);
			}) {
				unshift @search_dirs,
                        map { "$share/$_" }
                        qw (locale LocaleData);
            }
		}
		$bound_dirs{$textdomain} = [grep { -d $_ } @search_dirs];
    }

    Locale::TextDomain->export_to_level (1, $package, @EXPORT);

    return;
}

# Private functions.
sub __find_domain ($)
{
	my $domain = shift;

	my $try_dirs = $bound_dirs{$domain};

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

		TRYDIR: foreach my $dir (grep { -d $_ } @$try_dirs) {
			# Is there a message catalog?  We have to search recursively
			# for it.  Since globbing is reported to be buggy under
			# MS-DOS, we roll our own version.
			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) {
						# If we find a non-readable file on our way,
						# we access has been disabled on purpose.
						# Therefore no -r check here.
						$found_dir = $dir;
						last TRYDIR;
					}
				}
			}
		}

		# If there was no success, this will fall back to the default search
		# directories.
		bindtextdomain $domain => abs_path $found_dir;
    }

    # The search has completed.
    undef $bound_dirs{$domain};

    return 1;
}

sub __expand ($%)
{
    my ($translation, %args) = @_;

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

    return $translation;
}

1;

__END__