view release on metacpan or  search on metacpan

lib/HTML/Template/Compiled/Plugin/I18N.pm  view on Meta::CPAN

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{[}