File Coverage

blib/lib/Locale/Simple.pm

Criterion	Covered	Total	%
statement	69	93	74.1
branch	19	26	73.0
condition	9	9	100.0
subroutine	19	33	57.5
pod	0	17	0.0
total	116	178	65.1

package Locale::Simple;
BEGIN {
  $Locale::Simple::AUTHORITY = 'cpan:GETTY';
}
# ABSTRACT: Functions for translate text based on gettext data, also in JavaScript
$Locale::Simple::VERSION = '0.017';
use strict;
use warnings;

use Exporter 'import';
use Locale::TextDomain 1.23 (); # to ensure we get the right version of gettext_dumb
use Locale::gettext_dumb qw(:locale_h :libintl_h);
use POSIX qw' setlocale ';
use IO::All 0.41 -utf8;

our @EXPORT = qw(

	l_dir
	l_lang
	l_dry
	l_nolocales

	l
	ln
	lp
	lnp
	ld
	ldn
	ldp
	ldnp

	ltd

);

my $dry;
my $nowrite;
my $nolocales;

my %tds;
my $dir;

sub l_nolocales { $nolocales = shift }
sub l_dry { $dry = shift; $nowrite = shift; $nolocales = 1 if $dry }

sub gettext_escape {
	my ( $content ) = @_;
	$content =~ s/\\/\\\\/g;
	$content =~ s/\n/\\n/g;
	$content =~ s/"/\\"/g;
	return $content;
}

sub sprintf_compare {
	my ( $first, $second ) = @_;
	my $re = qr/(?:%%|%(?:[0-9]+\$)?[+-]?(?:[ 0]|\'.)?-?[0-9]*(?:\.[0-9]+)?[bcdeufFosxX])/;
	my @placeholder_first = sort { $a cmp $b } map { my @chars = split(//,$_); pop @chars; } ($first =~ m/$re/g);
	my @placeholder_second = sort { $a cmp $b } map { my @chars = split(//,$_); pop @chars; } ($second =~ m/$re/g);
	return join("",@placeholder_first) eq join("",@placeholder_second);
}

sub coderef_hash {{
	l => sub { l(@_) },
	ln => sub { ln(@_) },
	lp => sub { lp(@_) },
	lnp => sub { lnp(@_) },
	ld => sub { ld(@_) },
	ldn => sub { ldn(@_) },
	ldp => sub { ldp(@_) },
	ldnp => sub { ldnp(@_) },
}}

sub l_dir { $dir = shift }

sub l_lang {
	my $primary = shift;
	$ENV{LANGUAGE} = $primary;
	$ENV{LANG} = $primary;		# unsure if these ENV assignments are still needed with the setlocale below
	$ENV{LC_ALL} = $primary;
	$ENV{LC_MESSAGES} = $primary; # set locale for messages if the system supports it
	setlocale( LC_MESSAGES, $primary ) if eval { LC_MESSAGES }; # set locale for messages if the system supports it
}

# write dry
sub wd { io($dry)->append(join("\n",@_)."\n\n") if !$nowrite }

# l(msgid,...)
sub l { return ldnp('',undef,shift,undef,undef,@_) }
# ln(msgid,msgid_plural,count,...)
sub ln { return ldnp('',undef,@_) }
# lp(msgctxt,msgid,...)
sub lp { return ldnp('',shift,shift,undef,undef,@_) }
# lnp(msgctxt,msgid,msgid_plural,count,...)
sub lnp { return ldnp('',shift,shift,shift,shift,@_) }
# ld(domain,msgid,...)
sub ld { return ldnp(shift,undef,shift,undef,undef,@_) }
# ldn(domain,msgid,msgid_plural,count,...)
sub ldn { return ldnp(shift,undef,shift,shift,shift,@_) }
# ldp(domain,msgctxt,msgid,...)
sub ldp { return ldnp(shift,shift,shift,undef,undef,@_) }
# ldnp(domain,msgctxt,msgid,msgid_plural,count,...)
sub ldnp {
	die "please set a locale directory with l_dir() before using other translate functions" unless $dir || $nolocales;
	my ($td, $ctxt, $id, $idp, $n) = (shift,shift,shift,shift,shift);
	my @args = @_;
	unshift @args, $n if $idp;
	my $return;
	if ($dry) {
		if (!$nowrite) {
			my @save;
			push @save, '# domain: '.$td if $td;
			push @save, 'msgctxt "'.gettext_escape($ctxt).'"' if $ctxt;
			push @save, 'msgid "'.gettext_escape($id).'"';
			push @save, 'msgid_plural "'.gettext_escape($idp).'"' if $idp;
			wd(@save);
		}
		$return = sprintf($idp && $n != 1 ? $idp : $id, @args);
	} else {
		# L::TD handles msg ids as bytes internally
		utf8::encode($id);
		my $gt = dnpgettext($td, $ctxt, $id, $idp, $n);
		# Fixing bad utf8 handling
		utf8::decode($gt);
		$return = sprintf($gt,@args);
	}
	return $return;
}

sub ltd {
	die "please set a locale directory with l_dir() before using other translate functions" unless $dir || $nolocales;
	my $td = shift;
	unless (defined $tds{$td}) {
		bindtextdomain($td,$dir);
		bind_textdomain_codeset($td,'utf-8');
		$tds{$td} = 1;
	}
	textdomain($td);
}

1;

__END__