File Coverage

blib/lib/Locale/TextDomain/OO/Util/ExtractHeader.pm

Criterion	Covered	Total	%
statement	32	41	78.0
branch	3	12	25.0
condition			n/a
subroutine	10	12	83.3
pod	3	3	100.0
total	48	68	70.5

package Locale::TextDomain::OO::Util::ExtractHeader; ## no critic (TidyCode)

use strict;
use warnings;
use Carp qw(confess);
use English qw(-no_match_vars $EVAL_ERROR);
use Locale::TextDomain::OO::Util::Constants;
use Safe;
use namespace::autoclean;

our $VERSION = '3.006';

sub instance {
    return __PACKAGE__;
}

my $safe_already_done;
sub patch_safe_module {
    no warnings qw(redefine); ## no critic (NoWarnings)
    # make sure we don't ever double-wrap just in case
    if ( ! $safe_already_done++ ) {
        my $orig_code = *Safe::share_from{CODE};
        *Safe::share_from = sub {
            @{ $_[2] } = grep { length } @{ $_[2] }; # remove the offending zero-length $vars
            $orig_code->(@_);
        };
    }

    return __PACKAGE__;
}

my $perlify_plural_forms_ref__code_ref = sub {
    my $plural_forms_ref = shift;

    ${$plural_forms_ref} =~ s{ \b ( nplurals | plural | n ) \b }{\$$1}xmsg;

    return;
};

my $nplurals__code_ref = sub {
    my $plural_forms = shift;

    $perlify_plural_forms_ref__code_ref->(\$plural_forms);
    my $code = <<"EOC";
        my \$n = 0;
        my (\$nplurals, \$plural);
        $plural_forms;
        \$nplurals;
EOC
    my $nplurals = Safe->new->reval($code)
        or confess "Code of Plural-Forms $plural_forms is not safe, $EVAL_ERROR";

    return $nplurals;
};

my $plural__code_ref = sub {
    my $plural_forms = shift;

    return $plural_forms =~ m{ \b plural= ( [^;\n]+ ) }xms;
};

my $plural_code__code_ref = sub {
    my $plural_forms = shift;

    $perlify_plural_forms_ref__code_ref->(\$plural_forms);
    my $code = <<"EOC";
        sub {
            my \$n = shift;

            my (\$nplurals, \$plural);
            $plural_forms;

            return 0 + \$plural;
        }
EOC
    my $code_ref = Safe->new->reval($code)
        or confess "Code $plural_forms is not safe, $EVAL_ERROR";

    return $code_ref;
};

sub extract_header_msgstr {
    my ( undef, $header_msgstr ) = @_;

    defined $header_msgstr
        or confess 'Header is not defined';
    ## no critic (ComplexRegexes)
    my ( $plural_forms ) = $header_msgstr =~ m{
        ^
        Plural-Forms:
        [ ]*
        (
            nplurals [ ]* [=] [ ]* \d+   [ ]* [;]
            [ ]*
            plural   [ ]* [=] [ ]* [^;\n]+ [ ]* [;]?
            [ ]*
        )
        $
    }xms
        or confess 'Plural-Forms not found in header';
    ## use critic (ComplexRegexes)
    my ( $charset ) = $header_msgstr =~ m{
        ^
        Content-Type:
        [^;]+ [;] [ ]*
        charset [ ]* = [ ]*
        ( [^ ]+ )
        [ ]*
        $
    }xms
        or confess 'Content-Type with charset not found in header';
    my ( $lexicon_class ) = $header_msgstr =~ m{
        ^ X-Lexicon-Class: \s* ( \S* ) \s* $
    }xms;
    # ToDo: remove because multiplural was a too complicated idea
    my ( $multiplural_nplurals ) = $header_msgstr =~ m{
        ^ X-Multiplural-Nplurals: [ ]* ( \d+ ) [ ]* $
    }xms;

    return {(
        nplurals                 => $nplurals__code_ref->($plural_forms),
        plural                   => $plural__code_ref->($plural_forms),
        plural_code              => $plural_code__code_ref->($plural_forms),
        charset                  => $charset,
        ! $lexicon_class ? () : (
            lexicon_class        => $lexicon_class,
        ),
        # ToDo: remove because multiplural was a too complicated idea
        ! $multiplural_nplurals ? () : (
            multiplural_nplurals => $multiplural_nplurals,
        ),
    )};
}

1;

__END__