File Coverage

blib/lib/HTML/Template/Compiled/Plugin/I18N.pm

Criterion	Covered	Total	%
statement	195	210	92.8
branch	74	98	75.5
condition	6	8	75.0
subroutine	26	27	96.3
pod	5	5	100.0
total	306	348	87.9

package HTML::Template::Compiled::Plugin::I18N;

use strict;
use warnings;

our $VERSION = '1.04';

use Carp qw(croak);
use English qw(-no_match_vars $EVAL_ERROR);
use Hash::Util qw(lock_keys);
use Data::Dumper;
use HTML::Template::Compiled;
use HTML::Template::Compiled::Token;
use HTML::Template::Compiled::Plugin::I18N::DefaultTranslator;

our (%init, %escape_sub_of); ## no critic (PackageVars)

BEGIN {
    lock_keys(
        %init,
        qw(
            throw
            allow_maketext
            allow_gettext
            allow_formatter
            allow_unescaped
            translator_class
            escape_plugins
        ),
    );
}

sub _require_via_string {
    my $class = shift;

    eval "require $class" ## no critic (stringy eval)
        or _throw("Can not find package $class $EVAL_ERROR");

    return $class;
}

# class method
sub init {
    my ($class, %arg_of) = @_;

    # This escape plugins are already loaded.
    %escape_sub_of = (
        HTML     => \&HTML::Template::Compiled::Utils::escape_html,
        HTML_ALL => \&HTML::Template::Compiled::Utils::escape_html_all,
        URI      => \&HTML::Template::Compiled::Utils::escape_uri,
        JS       => \&HTML::Template::Compiled::Utils::escape_js,
        DUMP     => \&Dumper,
    );

    # Get the escape subs for each plugin ...
    my $escape_plugins = delete $arg_of{escape_plugins};
    if ($escape_plugins) {
        ref $escape_plugins eq 'ARRAY'
           or croak 'Parameter escape_plugins is not an array reference';
        for my $package ( @{$escape_plugins} ) {
            # register plugins
            my %escape = %{ _require_via_string($package)->register()->{escape} };
            SUB:
            for my $sub ( values %escape ) {
                # code ref given
                ref $sub eq 'CODE'
                    and next SUB;
                # sub name given
                no strict qw(refs); ## no critic (NoStrict)
                no warnings qw(redefine); ## no critic (NoWarnings)
                $sub = \&{$sub};
            }
            @escape_sub_of{ keys %escape } = values %escape;
        }
    }

    # ... and all the other boolenans and strings.
    my @keys = keys %arg_of;
    @init{@keys} = @arg_of{@keys};

    # Load the translator class.
    $init{translator_class} ||= 'HTML::Template::Compiled::Plugin::I18N::DefaultTranslator';
    _require_via_string($init{translator_class});

    # Register this plugin at HTC.
    HTML::Template::Compiled->register(__PACKAGE__);

    return $class;
}

# internal exception handler
sub _throw {
    my @message = @_;

    return
        ref $init{throw} eq 'CODE'
        ? $init{throw}->(@message)
        : croak @message;
}

# Register this plugin at HTC.
sub register {
    my ($class) = @_;

    return {
        # opening and closing tags to bind to
        tagnames => {
            HTML::Template::Compiled::Token::OPENING_TAG() => {
                TEXT => [
                    undef,
                    # attributes
                    qw(
                        NAME
                        VALUE
                        ESCAPE
                    ),
                    (
                        $init{allow_maketext}
                        ? qw(
                            _\d+
                            _\d+_VAR
                        )
                        : ()
                    ),
                    (
                        $init{allow_gettext}
                        ? qw(
                            PLURAL
                            PLURAL_VAR
                            COUNT
                            COUNT_VAR
                            CONTEXT
                            CONTEXT_VAR
                            _[A-Z][0-9A-Z_]*?
                            _[A-Z][0-9A-Z_]*?_VAR
                        )
                        : ()
                    ),
                    (
                        $init{allow_formatter}
                        ? qw(
                            FORMATTER
                        )
                        : ()
                    ),
                    (
                        $init{allow_unescaped}
                        ? qw(
                            UNESCAPED_[A-Z][0-9A-Z_]*?
                            UNESCAPED_[A-Z][0-9A-Z_]*?_VAR
                        )
                        : ()
                    ),
                ],
            },
        },
        compile => {
            # methods to compile to
            TEXT => {
                # on opening tab
                open => \&TEXT,
                # if you need closing, uncomment and implement method
                # close => \&close_text
            },
        },
    };
}

sub _lookup_variable {
    my ($htc, $var_name) = @_;

    return $htc->get_compiler()->parse_var(
        $htc,
        var            => $var_name,
        method_call    => $htc->method_call(),
        deref          => $htc->deref(),
        formatter_path => $htc->formatter_path(),
    );
}

sub _calculate_escape {
    my $arg_ref = shift;

    my @real_escapes;
    ESCAPE:
    for my $escape ( @{ $arg_ref->{escapes} } ) {
        # a '0' ignores all before
        if ($escape eq '0') {
            @real_escapes = ();
            next ESCAPE;
        }
        push @real_escapes, $escape;
    }
    # uc escape if no error
    my @unknown_escapes;
    ESCAPE:
    for my $escape (@real_escapes) {
        if ( exists $escape_sub_of{uc $escape} ) {
            $escape = uc $escape;
            next ESCAPE;
        }
        push @unknown_escapes, $escape;
    }
    # write back
    if ( exists $arg_ref->{escape_ref} ) {
        ${ $arg_ref->{escape_ref} } = \@real_escapes;
    }

    return @unknown_escapes ? \@unknown_escapes : ();
}

# Executes all needed escape subs.
sub _escape {
    my ($string, @escapes) = @_;

    @escapes
        or return $string;
    for (@escapes) {
        $string = $escape_sub_of{$_}->($string);
    }

    return $string;
}

# class method
sub escape {
    my (undef, $string, $escapes) = @_;

    return _escape($string, split m{,}xms, $escapes);
}

# class method
sub expand_unescaped {
    my (undef, $string, $arg_ref) = @_;

    my $regex = join q{|}, map { quotemeta $_ } keys %{$arg_ref};
    $string =~ s{
        \{ ($regex) \}
    }{
        defined $arg_ref->{$1} ? $arg_ref->{$1} : "{$1}"
    }xmsge;

    return $string;
}

# Prepare a string as Perl code.
sub _string_to_perl_code {
    my $string = shift;

    defined $string
        or return q{''};
    $string =~ s{\\}{\\}xmsg;
    $string =~ s{'}{\\'}xmsg;
    $string =~ s{"}{\\"}xmsg;

    return "'$string'";
}

# From here to subroutine TEXT: Caller is subroutine TEXT only.

sub _parse_attributes { ## no critic (ExcessComplexity)
    my ($attr_ref, $filename, $data_ref) = @_;

    my $package = __PACKAGE__;
    ATTRIBUTE:
    for my $name ( keys %{$attr_ref} ) {
        # parse ESCAPE
        if ($name eq 'ESCAPE') {
            if ( length $attr_ref->{$name} ) {
                $data_ref->{escape}->{array}
                    = [ split m{\|}xms, "0|$attr_ref->{$name}" ];
            }
        }
        if ( $init{allow_maketext} ) {
            # parse maketext placeholders
            # as string constant _1 .. _n
            # as variable _1_VAR .. _n_VAR
            my $is_maketext
                = my ($position, $is_variable)
                = $name =~ m{\A _ (\d+) (_VAR)? \z}xms;
            if ($is_maketext) {
                my $index = $position - 1;
                # _n, _n_VAR
                if ( exists $data_ref->{maketext}->{array}->[$index] ) {
                    _throw( qq{Error in template $filename, plugin $package. Can not use maktext position $position twice. $name="$attr_ref->{$name}"} );
                }
                $data_ref->{maketext}->{array}->[$index] = {
                    is_variable => $is_variable,
                    value       => $attr_ref->{$name},
                };
                next ATTRIBUTE;
            }
        }
        if ( $init{allow_gettext} ) {
            # parse gettext placeholders
            # as string constant _name_1 .. _name_n
            # as variable _name_1_VAR .. _name_n_VAR
            my $is_gettext
                = my ($key, $is_variable)
                = $name =~ m{\A _ ([A-Z][0-9A-Z_]*?) (_VAR)? \z}xms;
            if ($is_gettext) {
                # _name, _name_VAR
                if ( exists $data_ref->{gettext}->{hash}->{lc $key} ) {
                    _throw( qq{Error in template $filename, plugin $package. Can not use gettext key $key twice. $name="$attr_ref->{$name}"} );
                }
                $data_ref->{gettext}->{hash}->{lc $key} = {
                    is_variable => $is_variable,
                    value       => $attr_ref->{$name},
                };
                next ATTRIBUTE;
            }
            # parse gettext plural
            # as string constant PLURAL
            # as variable PLURAL_VAR
            my $is_plural
                = ($is_variable)
                = $name =~ m{\A PLURAL (_VAR)? \z}xms;
            if ($is_plural) {
                if ( exists $data_ref->{plural} ) {
                    _throw( qq{Error in template $filename, plugin $package. Can not use PLURAL/PLURAL_VAR twice. $name="$attr_ref->{$name}"} );
                }
                $data_ref->{plural} = {
                    is_variable => $is_variable,
                    value       => $attr_ref->{$name},
                };
                next ATTRIBUTE;
            }
            # parse gettext count
            # as string constant COUNT
            # as variable COUNT_VAR
            my $is_count
                = ($is_variable)
                = $name =~ m{\A COUNT (_VAR)? \z}xms;
            if ($is_count) {
                if ( exists $data_ref->{count} ) {
                    _throw( qq{Error in template $filename, plugin $package. Can not use COUNT/COUNT_VAR twice. $name="$attr_ref->{$name}"} );
                }
                $data_ref->{count} = {
                    is_variable => $is_variable,
                    value       => $attr_ref->{$name},
                };
                next ATTRIBUTE;
            }
            # parse gettext context
            # as string constant CONTEXT
            # as variable CONTEXT_VAR
            my $is_context
                = ($is_variable)
                = $name =~ m{\A CONTEXT (_VAR)? \z}xms;
            if ($is_context) {
                if ( exists $data_ref->{context} ) {
                    _throw( qq{Error in template $filename, plugin $package. Can not use CONTEXT/CONTEXT_VAR twice. $name="$attr_ref->{$name}"} );
                }
                $data_ref->{context} = {
                    is_variable => $is_variable,
                    value       => $attr_ref->{$name},
                };
                next ATTRIBUTE;
            }
        }
        if ( $init{allow_formatter} ) {
            # parse FORMATTER
            if ( $name eq 'FORMATTER' ) {
                if ( exists $data_ref->{formatter}->{array} ) {
                    _throw( qq{Error in template $filename, plugin $package. Can not use FORMATTER twice. $name="$attr_ref->{$name}"} );
                }
                $data_ref->{formatter}->{array} = [
                    map {
                        {value => $_};
                    } split m{\|}xms, $attr_ref->{$name}
                ];
                next ATTRIBUTE;
            }
        }
        if ( $init{allow_unescaped} ) {
            # parse unescaped placeholders
            # as string constant UNESCAPED_name_1 .. UNESCAPED_name_n
            # as variable UNESCAPED_name_1_VAR .. UNESCAPED_name_n_VAR
            my $is_unescaped
                = my ($key, $is_variable)
                = $name =~ m{\A UNESCAPED _ ([A-Z][0-9A-Z_]*?) (_VAR)? \z}xms;
            if ($is_unescaped) {
                # _name, _name_VAR
                if ( exists $data_ref->{unescaped}->{hash}->{lc $key} ) {
                    _throw( qq{Error in template $filename, plugin $package. Can not use unescaped key $key twice. $name="$attr_ref->{$name}"} );
                }
                $data_ref->{unescaped}->{hash}->{lc $key} = {
                    is_variable => $is_variable,
                    value       => $attr_ref->{$name},
                };
                next ATTRIBUTE;
            }
        }
    }
    # parse NAME/VALUE
    $data_ref->{text} = {
        exists $attr_ref->{NAME}
        ? (
            exists $attr_ref->{VALUE}
            ? _throw(
                qq{Error in template $filename, plugin $package. Do not use NAME and VALUE at the same time. NAME="$attr_ref->{NAME}" VALUE="$attr_ref->{VALUE}"}
            )
            : (
                is_variable => 1,
                value       => $attr_ref->{NAME},
            )
        )
        : (
            value => $attr_ref->{VALUE},
        )
    };

    return;
}

sub _check_escape {
    my ($data_ref, $htc, $filename) = @_;

    my $package = __PACKAGE__;
    my $unknown_escapes = _calculate_escape({
        escapes => [
            (
                split m{\|}xms, $htc->get_default_escape()
            ),
            (
                exists $data_ref->{escape}
                ? @{ $data_ref->{escape}->{array} }
                : ()
            ),
        ],
        escape_ref => \$data_ref->{escape}->{array},
    });
    if ($unknown_escapes) {
        my $escapes   = join ', ', @{$unknown_escapes};
        my $is_plural = @{$unknown_escapes} > 1;
        _throw(
            "Error in template $filename, plugin $package."
            . (
                $is_plural
                ? "Escapes $escapes at ESCAPE are unknown."
                : "Escape $escapes at ESCAPE is unknown."
            )
        );
    }
    if ( exists $data_ref->{escape} && ! @{ $data_ref->{escape}->{array} } ) {
        delete $data_ref->{escape};
    }

    return;
}

sub _prepare_htc_code {
    my ($data_ref, $htc) = @_;

    my $package = __PACKAGE__;

    # write code snippet
    my $to_perl_code = sub {
        my $data = shift;

        $data->{is_variable}
            and return _lookup_variable($htc, $data->{value});
        defined $data->{value}
            or return 'undef';

        return _string_to_perl_code( $data->{value} );
    };

    PREPARE_SCALAR:
    for my $key ( qw(filename text plural count context) ) {
        exists $data_ref->{$key}
            or next PREPARE_SCALAR;
        my $data = $data_ref->{$key};
        $data->{perl_code} = $to_perl_code->($data);
    }

    PREPARE_ARRAY:
    for my $key ( qw(maketext formatter) ) {
        exists $data_ref->{$key}
            or next PREPARE_ARRAY;
        my $data = $data_ref->{$key};
        $data->{perl_code}
            = q{[}
            . (
                join q{,}, map {
                    $to_perl_code->($_);
                } @{ $data->{array} }
            )
            . q{]};
    }

    PREPARE_HASH:
    for my $key ( qw(gettext unescaped) ) {
        exists $data_ref->{$key}
            or next PREPARE_HASH;
        my $data = $data_ref->{$key};
        $data->{perl_code}
            = q[{]
            . (
                join q{,}, map {
                    _string_to_perl_code($_)
                    . ' => '
                    . $to_perl_code->( $data->{hash}->{$_} )
                } keys %{ $data->{hash} }
            )
            . q[}];
    }

    # store escape itself
    PREPARE_JOINED_ARRAY:
    for my $key ( qw(escape) ) {
        exists $data_ref->{$key}
            or next PREPARE_JOINED_ARRAY;
        my $data = $data_ref->{$key};
        $data->{perl_code}
            = _string_to_perl_code(
                join q{,}, @{ $data->{array} }
        );
    }

    return;
}

sub TEXT {
    my ($htc, $token, $arg_ref) = @_;

    my $attr_ref = $token->get_attributes();
    my $filename = $htc->get_filename();

    my %data = (
        filename => {
            value => $filename,
        },
    );
    _parse_attributes($attr_ref, $filename, \%data);
    _check_escape(\%data, $htc, $filename);
    _prepare_htc_code(\%data, $htc);

    # necessary for HTC's caching mechanism
    my $inner_hash = join ', ', map {
        ( $_ eq 'filename' || exists $data{$_} )
        ? "$_ => $data{$_}->{perl_code}"
        : ();
    } keys %data;

    return <<"EO_CODE";
$arg_ref->{out} $init{translator_class}->translate({$inner_hash});
EO_CODE
}

1;

__END__