File Coverage

blib/lib/Localizer/Style/Gettext.pm

Criterion	Covered	Total	%
statement	66	66	100.0
branch	25	26	96.1
condition			n/a
subroutine	10	10	100.0
pod	0	2	0.0
total	101	104	97.1

package Localizer::Style::Gettext;
use strict;
use warnings;
use utf8;
use 5.010_001;

use B;
use Carp ();

sub new { bless {}, shift }

sub compile {
    my ($self, $msgid, $fmt, $functions) = @_;
    my $code = $self->_compile($msgid, $fmt, $functions);
    return $code;
}

sub _compile {
    my ($self, $msgid, $str, $functions) = @_;

    return \$str unless $str =~ /%/;

    my @code;
    my @bind;
    while ($str =~ m/
            (.*?)
            (?:
                ([\\%]%)
                |
                %(?:
                    ([A-Za-z#*]\w*)\(([^\)]*)\)
                    |
                    ([1-9]\d*|\*)
                )
                |
                $
            )
        /gsx
    ) {
        if ($1) { # Raw string
            my $text = $1;
            if ($text !~ m/[^\x20-\x7E]/s) { # ASCII very safe chars
                $text =~ s/\\/\\\\/g;
                push @code, B::perlstring($text) . ',';
            } else {
                # For example, `(eval "sub { qq{% usar\x{e1}n}}")->()` drops UTF-8 flag.
                # This code is the workaround for this issue.
                push @code, sprintf(q{$bind[%d],}, 0+@bind);
                push @bind, $text;
            }
        }
        if ($2) { # \% %%
            my $text = $2;
            $text =~ s/\\/\\\\\\\\/g;
            push @code, "'" . $text . "',";
        }
        elsif ($3) {
            my $function_name = $3;
            if ($function_name eq '*') {
                $function_name = 'quant';
            }
            elsif ($function_name eq '#') {
                $function_name = 'numf';
            }

            unless (exists $functions->{$function_name}) {
                Carp::confess("Language resource compilation error. Unknown function: '${function_name}'");
            }

            my $code = q!$functions->{'! . $function_name . q!'}->(!;
            for my $arg (split(/,/, $4)) {
                if (my ($num) = $arg =~ /%(\d+)/) {
                    $code .= '$_[' . $num . '], ';
                }
                else {
                    $code .= "'" . $arg . "', ";
                }
            }
            $code .= '), ';
            push @code, $code;
        }
        elsif ($5) {
            my $arg = $5;

            my $var = '';
            if ($arg eq '*') {
                $var = '@_[1 .. $#_],';
            }
            else {
                $var = '$_[' . $arg . '],';
            }
            push @code, $var;
        }
    }

    if (@code > 1) { # most cases, presumably!
        unshift @code, "join '',\n";
    }
    unshift @code, qq!#line 1 "${msgid}"\n!;
    unshift @code, "use strict; sub {\n";
    push @code, "}\n";

    my $sub = eval(join '', @code); ## no critic.
    die "Language resource compilation error: $@ while evalling" . join('', @code) if $@; # Should be impossible.
    return $sub;
}

1;
__END__