File Coverage

blib/lib/Text/Extract/MaketextCallPhrases.pm

Criterion	Covered	Total	%
statement	222	231	96.1
branch	130	154	84.4
condition	84	116	72.4
subroutine	9	9	100.0
pod	2	2	100.0
total	447	512	87.3

package Text::Extract::MaketextCallPhrases;

use strict;
use warnings;

$Text::Extract::MaketextCallPhrases::VERSION = '0.94';

use Text::Balanced      ();
use String::Unquotemeta ();

# So we don't have to maintain an identical regex
use Module::Want 0.6 ();
my $ns_regexp = Module::Want::get_ns_regexp();

my $NO_EXTRACT_KEY = '## no extract maketext';

sub import {
    no strict 'refs';    ## no critic
    *{ caller() . '::get_phrases_in_text' } = \&get_phrases_in_text;
    *{ caller() . '::get_phrases_in_file' } = \&get_phrases_in_file;
}

my $default_regexp_conf_item = [
    qr/(?:(?:^|\:|\s|=|\(|\.|\b)translatable|(?:make|lex)text(?:_[a-zA-Z0-9_]+_context)?)\s*\(?/,
    sub { return substr( $_[0], -1, 1 ) eq '(' ? qr/\s*\)/ : qr/\s*\;/ },
];

sub get_phrases_in_text {

    # 3rd arg is used internally to get the line number in the 'debug_ignored_matches' results when called via get_phrases_in_file(). Don't rely on this as it may change.
    my ( $text, $conf_hr, $linenum ) = @_;    # 3rd arg is used internally to get the line number in the 'debug_ignored_matches' results when called via get_phrases_in_file(). Don't rely on this as it may change.

    $conf_hr ||= {};

    if ( $conf_hr->{'encode_unicode_slash_x'} ) {
        Module::Want::have_mod('Encode') || die $@;
    }

    if ( $conf_hr->{'cpanel_mode'} && $conf_hr->{'cpanel_mode'} != 0 ) {
        $conf_hr->{'cpanel_mode'} = '0E0';
        push @{ $conf_hr->{'regexp_conf'} }, [ qr/\/ ], [ qr/(?:^|[^<])cptext\s*\(/, qr/\s*\)/ ], [ qr/Cpanel::Exception(?:::$ns_regexp)?->new\(/, qr/\s*\)/ ], [ qr/Cpanel::Exception(?:::$ns_regexp)?::create\(/, qr/\s*\)/, { 'optional' => 1, 'arg_position' => 2 } ], [ qr/Cpanel::Exception(?:::$ns_regexp)?\-\>create\(/, qr/\s*\)/, { 'optional' => 1 } ],
          [ qr/Cpanel::LocaleString->new\(\s*/, qr/\s*\)/ ];
    }

    my @results;
    my %offset_seen;

    # I like this alignment better than what tidy does, seems clearer to me even if a bit overkill perhaps
    #tidyoff
    for my $regexp (
        $conf_hr->{'regexp_conf'} ? (
                                        $conf_hr->{'no_default_regex'} ? @{ $conf_hr->{'regexp_conf'} }
                                                                       : ( $default_regexp_conf_item, @{ $conf_hr->{'regexp_conf'} } )
                                    )
                                  : ($default_regexp_conf_item)
    ) {
    #tidyon
        my $text_working_copy = $text;
        my $original_len      = length($text_working_copy);

        my $rx_conf_hr = defined $regexp->[2] && ref( $regexp->[2] ) eq 'HASH' ? $regexp->[2] : { 'optional' => 0, 'arg_position' => 0 };
        $rx_conf_hr->{arg_position} = exists $rx_conf_hr->{arg_position} ? int( abs( $rx_conf_hr->{arg_position} ) ) : 0;    # if caller passes a non-numeric value this should warn, that is a feature!

        my $token_rx = qr/$regexp->[0]/;
        my ( $did_match, $matched, $no_extract_index );
        while (1) {
            last if !defined $text_working_copy;

            $did_match = $text_working_copy =~ $token_rx;

            if ($did_match) {
                $no_extract_index = index(
                    substr( $text_working_copy, 0, $+[0] ),
                    $NO_EXTRACT_KEY,
                );
                $matched = substr( $text_working_copy, $-[0], $+[0] - $-[0] );
            }
            else {
                $no_extract_index = index( $text_working_copy, $NO_EXTRACT_KEY );
                last if -1 == $no_extract_index;
            }

            # we have a (possibly multiline) chunk w/ notation-not-preceded-by-token that we should ignore
            if ( -1 != $no_extract_index && ( !$did_match || ( $no_extract_index < $-[0] ) ) ) {
                $text_working_copy =~ s/.* \Q$NO_EXTRACT_KEY\E [^\n]*//x;
                next;
            }

            my $pre;

            # TODO: incorporate the \s* into results: 'post_token_ws' => $1 || '' ?
            ( $pre, $text_working_copy ) = split( m/(?:$regexp->[0]|$NO_EXTRACT_KEY)\s*/, $text_working_copy, 2 );    # the \s* takes into account trailing WS that Text::Balanced ignores which then can throw off the offset

            # we have a token line that we should ignore
            next if $text_working_copy =~ s/^[^\n]* \Q$NO_EXTRACT_KEY\E [^\n]*//x;

            my $offset = $original_len - length($text_working_copy);

            my $phrase;
            my $result_hr = { 'is_error' => 0, 'is_warning' => 0, 'offset' => $offset, 'regexp' => $regexp, 'matched' => $matched };

            if ( $conf_hr->{'ignore_perlish_comments'} ) {

                # ignore matches in a comment
                if ( $pre =~ m/\#/ && $pre !~ m/[\n\r]$/ ) {
                    my @lines = split( /[\n\r]+/, $pre );

                    if ( $lines[-1] =~ m/\#/ ) {
                        $result_hr->{'type'} = 'comment';
                        $result_hr->{'line'} = $linenum if defined $linenum;
                        push @{ $conf_hr->{'debug_ignored_matches'} }, $result_hr;
                        next;
                    }
                }
            }

            # ignore functions named *$1
            if ( $text_working_copy =~ m/^\s*\{/ && $matched !~ m/\(\s*$/ ) {
                $result_hr->{'type'} = 'function';
                $result_hr->{'line'} = $linenum if defined $linenum;
                push @{ $conf_hr->{'debug_ignored_matches'} }, $result_hr;
                next;
            }

            # ignore assignments to things named *maketext
            if ( $text_working_copy =~ m/^\s*=/ ) {
                $result_hr->{'type'} = 'assignment';
                $result_hr->{'line'} = $linenum if defined $linenum;
                push @{ $conf_hr->{'debug_ignored_matches'} }, $result_hr;
                next;
            }

            if ( $conf_hr->{'ignore_perlish_statement'} ) {

                # ignore a statement named *maketext (e.g. goto &XYZ::maketext;)
                if ( $text_working_copy =~ m/^\s*;/ ) {
                    $result_hr->{'type'} = 'statement';
                    $result_hr->{'line'} = $linenum if defined $linenum;
                    push @{ $conf_hr->{'debug_ignored_matches'} }, $result_hr;
                    next;
                }
            }

            # phrase is argument N (instead of first)
            if ( $rx_conf_hr->{'arg_position'} > 0 ) {

                # hack away the args before the one at $arg_position
                for my $at_index ( 1 .. $rx_conf_hr->{'arg_position'} ) {
                    $text_working_copy =~ s{^\s*\,\s*}{};
                    if ( $at_index >= $rx_conf_hr->{'arg_position'} ) {
                        $result_hr->{'offset'} = $original_len - length($text_working_copy);
                        last;
                    }

                    ( $phrase, $text_working_copy ) = Text::Balanced::extract_variable($text_working_copy);

                    if ( !defined $phrase ) {
                        ( $phrase, $text_working_copy ) = Text::Balanced::extract_quotelike($text_working_copy);
                    }
                }
            }

            ( $phrase, $text_working_copy ) = Text::Balanced::extract_variable($text_working_copy);
            my $optional_perlish =
                $text_working_copy =~ m/^\s*\[/ ? "ARRAY"
              : $text_working_copy =~ m/^\s*\{/ ? "HASH"
              :                                   0;

            if ( !$phrase ) {

                # undef $@;
                my ( $type, $inside, $opener, $closer );
                ( $phrase, $text_working_copy, undef, $type, $opener, $inside, $closer ) = Text::Balanced::extract_quotelike($text_working_copy);
                $text_working_copy = '' if !defined $text_working_copy;

                $result_hr->{'quotetype'} = 'single' if ( defined $opener && $opener eq "'" ) || ( defined $type && ( $type eq 'q' || $type eq 'qw' ) );
                $result_hr->{'quotetype'} = 'double' if ( defined $opener && $opener eq '"' ) || ( defined $type && $type eq 'qq' );
                if ( $result_hr->{'quotetype'} ) {
                    $result_hr->{'quote_before'} = $type . $opener;
                    $result_hr->{'quote_after'}  = $closer;
                }

                if ( defined $type && $type eq '<<' ) {
                    $result_hr->{'quote_before'} = $type . $opener;
                    $result_hr->{'quote_after'}  = $closer;

                    $result_hr->{'heredoc'} = $opener;
                    if ( substr( $opener, 0, 1 ) eq "'" ) {
                        $result_hr->{'quotetype'} = 'single';
                    }
                    else {
                        $result_hr->{'quotetype'} = 'double';
                    }
                }

                if ( defined $inside && ( exists $result_hr->{'quotetype'} ) && $inside eq '' ) {
                    $result_hr->{'is_error'} = 1;
                    $result_hr->{'type'}     = 'empty';
                    $phrase                  = $inside;
                }
                elsif ( defined $inside && $inside ) {
                    $phrase = $inside;

                    if ( $type eq 'qw' ) {
                        if ( $phrase =~ m/\A(\s+)/ ) {
                            $result_hr->{'quote_before'} .= $1;
                            $phrase =~ s/\A(\s+)//;
                        }
                        if ( $phrase =~ m/(\s+)\z/ ) {
                            $result_hr->{'quote_after'} = $1 . $result_hr->{'quote_after'};
                            $phrase =~ s/(\s+)\z//;
                        }

                        if ( $phrase =~ m/(\s+)/ ) {
                            $result_hr->{'quote_after'} = $1;
                        }

                        # otherwise leave quote_after asis for cases like this: qw(foo)

                        ($phrase) = split( /\s+/, $phrase, 2 );
                    }
                    elsif ( $type eq 'qx' || $opener eq '`' ) {
                        $result_hr->{'is_warning'} = 1;
                        $result_hr->{'type'}       = 'command';
                    }
                    elsif ( $type eq 'm' || $type eq 'qr' || $type eq 's' || $type eq 'tr' || $opener eq '/' ) {
                        $result_hr->{'is_warning'} = 1;
                        $result_hr->{'type'}       = 'pattern';
                    }
                }
                elsif ( defined $opener && defined $inside && defined $closer && defined $phrase && $phrase eq "$opener$inside$closer" ) {
                    $result_hr->{'is_error'} = 1;
                    $result_hr->{'type'}     = 'empty';
                    $phrase                  = $inside;
                }
                else {
                    my $is_no_arg = 0;
                    if ( defined $regexp->[1] ) {
                        if ( ref( $regexp->[1] ) eq 'CODE' ) {
                            my $rgx = $regexp->[1]->($matched);
                            if ( $text_working_copy =~ m/^$rgx/ ) {
                                $is_no_arg = 1;
                            }
                        }
                        elsif ( ref( $regexp->[1] ) eq 'Regexp' ) {
                            my $rgx = qr/^$regexp->[1]/;
                            if ( $text_working_copy =~ $rgx ) {
                                $is_no_arg = 1;
                            }
                        }
                    }

                    if ($is_no_arg) {
                        if ( $rx_conf_hr->{'optional'} ) {
                            next;
                        }
                        else {
                            $result_hr->{'is_error'} = 1;
                            $result_hr->{'type'}     = 'no_arg';
                        }
                    }
                    elsif ( $text_working_copy =~ m/^\s*(((?:\&|\\\*)?)$ns_regexp(?:\-\>$ns_regexp)?((?:\s*\()?))/o ) {
                        $phrase = $1;
                        my $perlish = $2 || $3 ? 1 : 0;

                        $text_working_copy =~ s/\s*(?:\&|\\\*)?$ns_regexp(?:\-\>$ns_regexp)?(?:\s*\()?\s*//o;

                        $result_hr->{'is_warning'} = 1;
                        $result_hr->{'type'} = $perlish ? 'perlish' : 'bareword';
                    }
                }
            }
            else {
                $result_hr->{'is_warning'} = 1;
                $result_hr->{'type'}       = 'perlish';
            }

            if ( !defined $phrase ) {
                my $is_no_arg = 0;
                if ( defined $regexp->[1] ) {
                    if ( ref( $regexp->[1] ) eq 'CODE' ) {
                        my $rgx = $regexp->[1]->($matched);
                        if ( $text_working_copy =~ m/^$rgx/ ) {
                            $is_no_arg = 1;
                        }
                    }
                    elsif ( ref( $regexp->[1] ) eq 'Regexp' ) {
                        my $rgx = qr/^$regexp->[1]/;
                        if ( $text_working_copy =~ $rgx ) {
                            $is_no_arg = 1;
                        }
                    }
                }

                if ($is_no_arg) {
                    if ( $rx_conf_hr->{'optional'} ) {
                        next;
                    }
                    else {
                        $result_hr->{'is_error'} = 1;
                        $result_hr->{'type'}     = 'no_arg';
                    }
                }
                else {
                    if ($optional_perlish) {
                        if ( $rx_conf_hr->{'optional'} ) {
                            next;
                        }
                        else {
                            $result_hr->{'is_warning'} = 1;
                            $result_hr->{'type'}       = 'perlish';
                            $phrase                    = $optional_perlish;
                        }
                    }
                    else {
                        $result_hr->{'is_warning'} = 1;
                        $result_hr->{'type'}       = 'multiline';
                    }
                }
            }
            else {
                $result_hr->{'original_text'} = $phrase;

                # make sure its wasn't a tricky variable in quotes like maketext("$foo->{zip}")
                # '$foo->{zip}' '   $foo->{zip} ' " $foo->{zip} " to but that seems like a good idea to flag as wonky and in need of human follow up
                my ( $var, $for, $aft ) = Text::Balanced::extract_variable($phrase);
                if ( $var && defined $for && defined $aft && $for =~ m/\A\s*\z/ && $aft =~ m/\A\s*\z/ ) {
                    $result_hr->{'is_warning'} = 1;
                    $result_hr->{'type'}       = 'perlish';
                }
                else {
                    if ( exists $result_hr->{'quotetype'} ) {
                        if ( $result_hr->{'quotetype'} eq 'single' ) {

                            # escape \n\t etc to preserver them during unquotemeta()
                            $phrase =~ s{(\\(?:n|t|f|r|a|b))}{\\$1}g;
                        }
                        elsif ( $result_hr->{'quotetype'} eq 'double' ) {

                            # interpolate \n\t etc
                            $phrase =~ s{(\\(?:n|t|f|r|a|b))}{eval qq{"$1"}}eg;
                        }
                    }

                    if ( $conf_hr->{'encode_unicode_slash_x'} ) {

                        # Turn Unicode string \x{} into bytes strings
                        $phrase =~ s{(\\x\{[0-9a-fA-F]+\})}{Encode::encode_utf8( eval qq{"$1"} )}eg;
                    }
                    else {

                        # Preserve Unicode string \x{} for unquotemeta()
                        $phrase =~ s{(\\)(x\{[0-9a-fA-F]+\})}{$1$1$2}g;
                    }

                    # Turn graphemes into characters to avoid quotemeta() problems
                    $phrase =~ s{((:?\\x[0-9a-fA-F]{2})+)}{eval qq{"$1"}}eg;
                    $phrase = String::Unquotemeta::unquotemeta($phrase) unless exists $result_hr->{'type'} && $result_hr->{'type'} eq 'perlish';
                }
            }

            $result_hr->{'phrase'} = $phrase;

            push @results, $result_hr if ++$offset_seen{ $result_hr->{'offset'} } == 1;
        }
    }

    return [ sort { $a->{'offset'} <=> $b->{'offset'} } @results ];
}

sub get_phrases_in_file {
    my ( $file, $regex_conf ) = @_;

    open my $fh, '<', $file or return;

    my @results;
    my $prepend       = '';
    my $linenum       = 0;
    my $in_multi_line = 0;
    my $line;    # buffer

    while ( $line = readline($fh) ) {
        $linenum++;

        my $initial_result_count = @results;
        push @results, map { $_->{'file'} = $file; $_->{'line'} = $in_multi_line ? $in_multi_line : $linenum; $_ } @{ get_phrases_in_text( $prepend . $line, $regex_conf, $linenum ) };
        my $updated_result_count = @results;

        if ( $in_multi_line && $updated_result_count == $initial_result_count ) {
            $prepend = $prepend . $line;
            next;
        }
        elsif ( $in_multi_line && $updated_result_count > $initial_result_count && $results[-1]->{'type'} ) {
            $prepend = $prepend . $line;
            pop @results;
            next;
        }
        elsif ( !$in_multi_line && @results && defined $results[-1]->{'type'} && $results[-1]->{'type'} eq 'multiline' ) {
            $in_multi_line = $linenum;
            my $trailing_partial = pop @results;

            require bytes;
            my $offset = $trailing_partial->{'offset'} > bytes::length( $prepend . $line ) ? bytes::length( $prepend . $line ) : $trailing_partial->{'offset'};
            $prepend = $trailing_partial->{'matched'} . substr( "$prepend$line", $offset );
            next;
        }
        else {
            $in_multi_line = 0;
            $prepend       = '';
        }
    }

    close $fh;

    return \@results;
}

1;

__END__