File Coverage

blib/lib/Locale/TextDomain/OO/Extract/Perl.pm

Criterion	Covered	Total	%
statement	138	151	91.3
branch	43	56	76.7
condition	5	8	62.5
subroutine	18	18	100.0
pod	4	4	100.0
total	208	237	87.7

package Locale::TextDomain::OO::Extract::Perl; ## no critic (TidyCode)

use strict;
use warnings;
use Carp qw(confess);
use Moo;
use MooX::Types::MooseLike::Base qw(ArrayRef Str);
use namespace::autoclean;

our $VERSION = '2.011';

extends qw(
    Locale::TextDomain::OO::Extract::Base::RegexBasedExtractor
);
with qw(
    Locale::TextDomain::OO::Extract::Role::File
);

has filter => (
    is      => 'rw',
    isa     => ArrayRef[Str],
    lazy    => 1,
    default => sub {[ 'all' ]},
);

sub _filtered_start_rule {
    my $self = shift;

    my %filter_of = map { $_ => 1 } @{ $self->filter };
    my $list_if = sub {
        my ( $key, @list ) = @_;
        my $condition
            = $filter_of{all} && ! $filter_of{"!$key"}
            || $filter_of{$key};
        return $condition ? @list : ();
    };
    my $with_bracket = join "\n| ", (
        $list_if->('Gettext',                           'N? __ n? p? x?'),
        $list_if->('Gettext::DomainAndCategory',        'N? __ d? c? n? p? x?'),
        $list_if->('Gettext::Loc',                      'N? loc_ n? p? x?'),
        $list_if->('Gettext::Loc::DomainAndCategory',   'N? loc_ d? c? n? p? x?'),
        $list_if->('BabelFish::Loc',                    'N? loc_b p?'),
        $list_if->('BabelFish::Loc::DomainAndCategory', 'N? loc_b d? c? p?'),
        $list_if->('Maketext::Loc',                     'N? loc (?: _mp? )?'),
        $list_if->('Maketext::Localise',                'N? localise (?: _mp? )?'),
        $list_if->('Maketext::Localize',                'N? localize (?: _mp? )?'),
        $list_if->('Maketext',                          'N? maketext (?: _p )?'),
        $list_if->('Gettext::DomainAndCategory',        '__begin_ d? c?'),
        $list_if->('Gettext::Loc::DomainAndCategory',   'loc_begin_ d? c?'),
        $list_if->('BabelFish::Loc::DomainAndCategory', 'loc_begin_b d? c?'),
    );
    $with_bracket ||= '(?!)';
    my $without = join q{}, map { "\n| $_" } (
        $list_if->('Gettext::DomainAndCategory',        '__end_ d? c?'),
        $list_if->('Gettext::Loc::DomainAndCategory',   'loc_end_ d? c?'),
        $list_if->('BabelFish::Loc::DomainAndCategory', 'loc_end_b d? c?'),
    );

    return qr{
        \b
        (?:
            (?: $with_bracket ) \s* [(]
            $without
        )
    }xms;
}

my $category_rule
    = my $context_rule
    = my $domain_rule
    = my $domain_or_category_rule
    = my $plural_rule
    = my $singular_rule
    = my $text_rule
    = [
        [
            # 'text with 0 .. n escaped chars'
            qr{
                \s* ( ['] )
                (
                    [^\\']*              # normal text
                    (?: \\ . [^\\']* )*  # maybe followed by escaped char and normal text
                )
                [']
            }xms,
        ],
        'or',
        [
            # "text with 0 .. n escaped chars"
            qr{
                \s* ( ["] )
                (
                    [^\\"]*              # normal text
                    (?: \\ . [^\\"]* )*  # maybe followed by escaped char and normal text
                )
                ["]
            }xms,
        ],
        'or',
        [
            # q{text with 0 .. n {placeholders} and/or 0 .. n escaped chars}
            ## no critic (EscapedMetacharacters)
            qr{
                \s* ( qq? \{ )        # q curly bracket quoted
                (
                    (?:
                        [^\{\}\\]     # normal text
                        | \\ .        # escaped char
                        | \{ (?-1) \} # any pairs of curly brackets with the same stuff inside
                    )*
                )
                \}                    # end of quote
            }xms,
            ## use critic (EscapedMetacharacters)
        ],
    ];
my $comma_rule = qr{ \s* [,] }xms;
my $count_rule = qr{ \s* ( [^,)]+ ) }xms;
my $close_rule = qr{ \s* [,]? \s* ( [^)]* ) [)] }xms;

my $rules = [
    # loc_, __
    [
        'begin',
        qr{ \b N? (?: loc_ | __ ) ( x? ) \s* [(] }xms,
        'and',
        $text_rule,
        'and',
        $close_rule,
        'end',
    ],
    'or',
    [
        'begin',
        qr{ \b N? (?: loc_ | __ ) ( n x? ) \s* [(] }xms,
        'and',
        $singular_rule,
        'and',
        $comma_rule,
        'and',
        $plural_rule,
        'and',
        $comma_rule,
        'and',
        $count_rule,
        'and',
        $close_rule,
        'end',
    ],
    'or',
    [
        'begin',
        qr{ \b N? (?: loc_ | __ ) ( p x? ) \s* [(] }xms,
        'and',
        $context_rule,
        'and',
        $comma_rule,
        'and',
        $text_rule,
        'and',
        $close_rule,
        'end',
    ],
    'or',
    [
        'begin',
        qr{ \b N? (?: loc_ | __ ) ( np x? ) \s* [(] }xms,
        'and',
        $context_rule,
        'and',
        $comma_rule,
        'and',
        $singular_rule,
        'and',
        $comma_rule,
        'and',
        $plural_rule,
        'and',
        $comma_rule,
        'and',
        $count_rule,
        'and',
        $close_rule,
        'end',
    ],

    # loc_d, __d
    'or',
    [
        'begin',
        qr{ \b N? (?: loc_ | __ ) ( d x? ) \s* [(] }xms,
        'and',
        $domain_rule,
        'and',
        $comma_rule,
        'and',
        $text_rule,
        'and',
        $close_rule,
        'end',
    ],
    'or',
    [
        'begin',
        qr{ \b N? (?: loc_ | __ ) ( dn x? ) \s* [(] }xms,
        'and',
        $domain_rule,
        'and',
        $comma_rule,
        'and',
        $singular_rule,
        'and',
        $comma_rule,
        'and',
        $plural_rule,
        'and',
        $comma_rule,
        'and',
        $count_rule,
        'and',
        $close_rule,
        'end',
    ],
    'or',
    [
        'begin',
        qr{ \b N? (?: loc_ | __ ) ( dp x? ) \s* [(] }xms,
        'and',
        $domain_rule,
        'and',
        $comma_rule,
        'and',
        $context_rule,
        'and',
        $comma_rule,
        'and',
        $text_rule,
        'and',
        $close_rule,
        'end',
    ],
    'or',
    [
        'begin',
        qr{ \b N? (?: loc_ | __ ) ( dnp x? ) \s* [(] }xms,
        'and',
        $domain_rule,
        'and',
        $comma_rule,
        'and',
        $context_rule,
        'and',
        $comma_rule,
        'and',
        $singular_rule,
        'and',
        $comma_rule,
        'and',
        $plural_rule,
        'and',
        $comma_rule,
        'and',
        $count_rule,
        'and',
        $close_rule,
        'end',
    ],

    # loc_c, __c
    'or',
    [
        'begin',
        qr{ \b N? (?: loc_ | __ ) ( c x? ) \s* [(] }xms,
        'and',
        $text_rule,
        'and',
        $comma_rule,
        'and',
        $category_rule,
        'and',
        $close_rule,
        'end',
    ],
    'or',
    [
        'begin',
        qr{ \b N? (?: loc_ | __ ) ( cn x? ) \s* [(] }xms,
        'and',
        $singular_rule,
        'and',
        $comma_rule,
        'and',
        $plural_rule,
        'and',
        $comma_rule,
        'and',
        $count_rule,
        'and',
        $comma_rule,
        'and',
        $category_rule,
        'and',
        $close_rule,
        'end',
    ],
    'or',
    [
        'begin',
        qr{ \b N? (?: loc_ | __ ) ( cp x? ) \s* [(] }xms,
        'and',
        $context_rule,
        'and',
        $comma_rule,
        'and',
        $text_rule,
        'and',
        $comma_rule,
        'and',
        $category_rule,
        'and',
        $close_rule,
        'end',
    ],
    'or',
    [
        'begin',
        qr{ \b N? (?: loc_ | __ ) ( cnp x? ) \s* [(] }xms,
        'and',
        $context_rule,
        'and',
        $comma_rule,
        'and',
        $singular_rule,
        'and',
        $comma_rule,
        'and',
        $plural_rule,
        'and',
        $comma_rule,
        'and',
        $count_rule,
        'and',
        $comma_rule,
        'and',
        $category_rule,
        'and',
        $close_rule,
        'end',
    ],

    # loc_dc, __dc
    'or',
    [
        'begin',
        qr{ \b N? (?: loc_ | __ ) ( dc x? ) \s* [(] }xms,
        'and',
        $domain_rule,
        'and',
        $comma_rule,
        'and',
        $text_rule,
        'and',
        $comma_rule,
        'and',
        $category_rule,
        'and',
        $close_rule,
        'end',
    ],
    'or',
    [
        'begin',
        qr{ \b N? (?: loc_ | __ ) ( dcn x? ) \s* [(] }xms,
        'and',
        $domain_rule,
        'and',
        $comma_rule,
        'and',
        $singular_rule,
        'and',
        $comma_rule,
        'and',
        $plural_rule,
        'and',
        $comma_rule,
        'and',
        $count_rule,
        'and',
        $comma_rule,
        'and',
        $category_rule,
        'and',
        $close_rule,
        'end',
    ],
    'or',
    [
        'begin',
        qr{ \b N? (?: loc_ | __ ) ( dcp x? ) \s* [(] }xms,
        'and',
        $domain_rule,
        'and',
        $comma_rule,
        'and',
        $context_rule,
        'and',
        $comma_rule,
        'and',
        $text_rule,
        'and',
        $comma_rule,
        'and',
        $category_rule,
        'and',
        $close_rule,
        'end',
    ],
    'or',
    [
        'begin',
        qr{ \b N? (?: loc_ | __ ) ( dcnp x? ) \s* [(] }xms,
        'and',
        $domain_rule,
        'and',
        $comma_rule,
        'and',
        $context_rule,
        'and',
        $comma_rule,
        'and',
        $singular_rule,
        'and',
        $comma_rule,
        'and',
        $plural_rule,
        'and',
        $comma_rule,
        'and',
        $count_rule,
        'and',
        $comma_rule,
        'and',
        $category_rule,
        'and',
        $close_rule,
        'end',
    ],

    # loc_b... (BabelFish)
    'or',
    [
        'begin',
        qr{ \b N? loc_b () \s* [(] }xms,
        'and',
        $text_rule,
        'and',
        $close_rule,
        'end',
    ],
    'or',
    [
        'begin',
        qr{ \b N? loc_b ( p ) \s* [(] }xms,
        'and',
        $context_rule,
        'and',
        $comma_rule,
        'and',
        $text_rule,
        'and',
        $close_rule,
        'end',
    ],
    'or',
    [
        'begin',
        qr{ \b N? loc_b ( d ) \s* [(] }xms,
        'and',
        $domain_rule,
        'and',
        $comma_rule,
        'and',
        $text_rule,
        'and',
        $close_rule,
        'end',
    ],
    'or',
    [
        'begin',
        qr{ \b N? loc_b ( dp ) \s* [(] }xms,
        'and',
        $domain_rule,
        'and',
        $comma_rule,
        'and',
        $context_rule,
        'and',
        $comma_rule,
        'and',
        $text_rule,
        'and',
        $close_rule,
        'end',
    ],
    'or',
    [
        'begin',
        qr{ \b N? loc_b ( c ) \s* [(] }xms,
        'and',
        $text_rule,
        'and',
        $comma_rule,
        'and',
        $category_rule,
        'and',
        $close_rule,
        'end',
    ],
    'or',
    [
        'begin',
        qr{ \b N? loc_b ( cp ) \s* [(] }xms,
        'and',
        $context_rule,
        'and',
        $comma_rule,
        'and',
        $text_rule,
        'and',
        $comma_rule,
        'and',
        $category_rule,
        'and',
        $close_rule,
        'end',
    ],
    'or',
    [
        'begin',
        qr{ \b N? loc_b ( dc ) \s* [(] }xms,
        'and',
        $domain_rule,
        'and',
        $comma_rule,
        'and',
        $text_rule,
        'and',
        $comma_rule,
        'and',
        $category_rule,
        'and',
        $close_rule,
        'end',
    ],
    'or',
    [
        'begin',
        qr{ \b N? loc_b ( dcp ) \s* [(] }xms,
        $domain_rule,
        'and',
        $comma_rule,
        'and',
        $context_rule,
        'and',
        $comma_rule,
        'and',
        $text_rule,
        'and',
        $comma_rule,
        'and',
        $category_rule,
        'and',
        $close_rule,
        'end',
    ],

    # maketext loc, localise, localize
    'or',
    [
        'begin',
        qr{ \b N? loc (?: ali[sz]e )? (?: _m )? () \s* [(] }xms,
        'and',
        $text_rule,
        'and',
        $close_rule,
        'end',
    ],
    'or',
    [
        'begin',
        qr{ \b N? loc (?: ali[sz]e )? _m ( p ) \s* [(] }xms,
        'and',
        $context_rule,
        'and',
        $comma_rule,
        'and',
        $text_rule,
        'and',
        $close_rule,
        'end',
    ],

    # maketext
    'or',
    [
        'begin',
        qr{ \b N? maketext () \s* [(] }xms,
        'and',
        $text_rule,
        'and',
        $close_rule,
        'end',
    ],
    'or',
    [
        'begin',
        qr{ \b N? maketext_ ( p ) \s* [(] }xms,
        'and',
        $context_rule,
        'and',
        $comma_rule,
        'and',
        $text_rule,
        'and',
        $close_rule,
        'end',
    ],

    # begin
    'or',
    [
        'begin',
        qr{ \b (?: loc_ | __ ) ( begin ) _ ( [dc] ) \s* [(] }xms,
        'and',
        $domain_or_category_rule,
        'end',
    ],
    'or',
    [
        'begin',
        qr{ \b (?: loc_ | __ ) ( begin ) [_] ( dc ) \s* [(] }xms,
        'and',
        $domain_rule,
        'and',
        $comma_rule,
        'and',
        $category_rule,
        'end',
    ],
    'or',
    [
        'begin',
        qr{ \b loc_begin_b ( [dc] ) \s* [(] }xms,
        'and',
        $domain_or_category_rule,
        'end',
    ],
    'or',
    [
        'begin',
        qr{ \b loc_begin_b ( dc ) \s* [(] }xms,
        'and',
        $domain_rule,
        'and',
        $comma_rule,
        'and',
        $category_rule,
        'end',
    ],

    # end
    'or',
    [
        'begin',
        qr{ \b (?: loc_ | __ ) ( end ) [_] ( [dc] ) \b }xms,
        'end',
    ],
    'or',
    [
        'begin',
        qr{ \b (?: loc_ | __ ) ( end ) [_] ( dc ) \b }xms,
        'end',
    ],
    'or',
    [
        'begin',
        qr{ \b loc_end_b ( [dc] ) \b }xms,
        'end',
    ],
    'or',
    [
        'begin',
        qr{ \b loc_end_b ( dc ) \b }xms,
        'end',
    ],
];

# remove pod and all lines after __END__, handle different newlines
sub preprocess {
    my $self = shift;

    my $content_ref = $self->content_ref;

    # remove all lines after __END__
    # replace pod without killing the line number
    my ($is_pod, $is_end);
    ${$content_ref}
        = join "\n",
        map {
            $_ eq '__END__'          ? do { $is_end = 1; q{} }
            : $is_end                ? ()
            : m{ \A [=] ( \w+ ) }xms ? (
                lc $1 eq 'cut'
                ? do { $is_pod = 0; q{} }
                : do { $is_pod = 1; q{} }
            )
            : $is_pod                ? q{}
            : $_;
        }
        split m{ \r? \n }xms, ${$content_ref};

    # replace heredoc's without killing the line number
    # <<'...'
    REPLACE: {
        ${$content_ref} =~ s{
            << \s* ' ( \w+ ) ' ( [^\n]* ) \n
            ( .*? )
            ^ \1 $
        }
        {
            qq{\n'}
            . do { my $text = $3; $text =~ s{'}{\\'}xmsg; $text }
            . q{'}
            . $2
        }xmsge and redo REPLACE;
    }
    # <<...
    # <<"..."
    REPLACE: {
        ${$content_ref} =~ s{
            << \s* ( ["]? ) ( \w+ ) \1 ( [^\n]* ) \n
            ( .*? )
            ^ \2 $
        }
        {
            qq{\n"}
            . do { my $text = $4; $text =~ s{"}{\\"}xmsg; $text }
            . q{"}
            . $3
        }xmsge and redo REPLACE;
    }

    return $self;
}

sub interpolate_escape_sequence {
    my ( undef, $string, $quot ) = @_;

    # nothing to interpolate
    defined $string
        or return $string;
    defined $quot
        or confess 'Quote expected';

    my $is_interpolate = $quot eq q{"} || $quot eq 'qq{';
    if ( ! $is_interpolate ) {
        # '...'
        if ( $quot eq q{'} ) {
            $string =~ s{ \\ ( ['] ) }{$1}xmsg;
            return $string;
        }
        # q{...}
        if ( $quot eq 'q{' ) {
            $string =~ s{ \\ ( [\{\}] ) }{$1}xmsg; ## no critic (EscapedMetacharacters)
            return $string;
        }
        confess "Unknown quot $quot";
    }

    # "..."
    # qq{...}
    my %char_of = (
        b => "\b",
        f => "\f",
        n => "\n",
        r => "\r",
        t => "\t",
    );
    $string =~ s{
        \\
        (?:
            ( [bfnrt] ) # Backspace
                        # Form feed
                        # New line
                        # Carriage return
                        # Horizontal tab
            | ( [xN] )  # do not handle \x.., \x{...}, \N{...}
            | (.)       # Backslash itself
                        # Single quotation mark
                        # Double quotation mark
                        # anything else that needs no escape
        )
    }{
        $1   ? $char_of{$1}
        : $2 ? "\\$2"
        :      $3
    }xmsge;

    return $string;
}

sub stack_item_mapping {
    my $self = shift;

    my $match = $_->{match};
    # The chars e.g. after loc_ were stored to make a decision now.
    my $extra_parameter = shift @{$match};
    @{$match}
        or return;

    if ( $extra_parameter eq 'begin' ) {
        {
            d => sub {
                push @{ $self->domain_stack }, $self->domain;
                $self->domain(
                    scalar $self->interpolate_escape_sequence(
                        reverse splice @{$match}, 0, 2
                    ),
                );
            },
            c => sub {
                push @{ $self->category_stack }, $self->category;
                $self->category(
                    scalar $self->interpolate_escape_sequence(
                        reverse splice @{$match}, 0, 2
                    ),
                );
            },
            dc => sub {
                push @{ $self->domain_stack }, $self->domain;
                $self->domain(
                    scalar $self->interpolate_escape_sequence(
                        reverse splice @{$match}, 0, 2
                    ),
                );
                push @{ $self->category_stack }, $self->category;
                $self->category(
                    scalar $self->interpolate_escape_sequence(
                        reverse splice @{$match}, 0, 2
                    ),
                );
            },
        }->{ shift @{$match} }->();
        return;
    }
    if ( $extra_parameter eq 'end' ) {
        {
            d => sub {
                @{ $self->domain_stack }
                    or confess 'Domain stack is empty because end_d is called without begin_d or begin_dc before';
                $self->domain( pop @{ $self->domain_stack } );
            },
            c => sub {
                @{ $self->category_stack }
                    or confess 'Category stack is empty because end_c is called without begin_c or begin_dc before';
                $self->category( pop @{ $self->category_stack } );
            },
            dc => sub {
                @{ $self->domain_stack }
                    or confess 'Domain stack is empty because end_dc is called without begin_d or begin_dc before';
                @{ $self->category_stack }
                    or confess 'Category stack is empty because end_dc is called without begin_c or begin_dc before';
                $self->domain( pop @{ $self->domain_stack } );
                $self->category( pop @{ $self->category_stack } );
            },
        }->{ shift @{$match} }->();
        return;
    }

    my $count;
    $self->add_message({
        reference    => ( sprintf '%s:%s', $self->filename, $_->{line_number} ),
        domain       => $extra_parameter =~ m{ d }xms
            ? scalar $self->interpolate_escape_sequence(
                reverse splice @{$match}, 0, 2
            )
            : $self->domain,
        msgctxt      => $extra_parameter =~ m{ p }xms
            ? scalar $self->interpolate_escape_sequence(
                reverse splice @{$match}, 0, 2
            )
            : undef,
        msgid        => scalar $self->interpolate_escape_sequence(
            reverse splice @{$match}, 0, 2
        ),
        msgid_plural => $extra_parameter =~ m{ n }xms
            ? do {
                my $plural = $self->interpolate_escape_sequence(
                    reverse splice @{$match}, 0, 2
                );
                $count = shift @{$match};
                $plural;
            }
            : undef,
        category     => $extra_parameter =~ m{ c }xms
            ? scalar $self->interpolate_escape_sequence(
                reverse splice @{$match}, 0, 2
            )
            : $self->category,
        automatic    => do {
            my $placeholders = shift @{$match};
            my $string = join ', ', map { ## no critic (MutatingListFunctions)
                defined $_
                ? do {
                    s{ \s+ }{ }xmsg;
                    s{ \s+ \z }{}xms;
                    length $_ ? $_ : ();
                }
                : ();
            } ( $count, $placeholders );
            $string =~ s{ \A ( .{70} ) .+ \z }{$1 ...}xms;
            $string;
        },
    });

    return;
}

sub extract {
    my $self = shift;

    $self->start_rule( $self->_filtered_start_rule );
    $self->rules($rules);
    $self->preprocess;
    $self->SUPER::extract;
    for ( @{ $self->stack } ) {
        $self->stack_item_mapping;
    }

    return $self;
}

__PACKAGE__->meta->make_immutable;

1;

__END__