File Coverage

blib/lib/Locale/Maketext/Utils/Phrase.pm

Criterion	Covered	Total	%
statement	81	83	97.5
branch	46	52	88.4
condition	56	71	78.8
subroutine	16	16	100.0
pod	9	9	100.0
total	208	231	90.0

package Locale::Maketext::Utils::Phrase;

use strict;
use warnings;
use Carp ();

use Module::Want ();

$Locale::Maketext::Utils::Phrase::VERSION = '0.1';

my $closing_bn = qr/(?
my $opening_bn = qr/(?
my $bn_delimit = qr/(?
my $bn_var_arg = qr/(?

sub get_bn_var_regexp {
    return qr/(?
}

sub get_non_translatable_type_regexp {
    return qr/(?:var|meth|basic_var)/;
}

sub string_has_opening_or_closing_bracket {
    return $_[0] =~ m/$opening_bn/ || $_[0] =~ m/$closing_bn/;
}

sub phrase2struct {
    my ($phrase) = @_;

    # Makes parsing (via code or mentally) unnecessarily difficult.
    #   ? TODO ? s/~~/_TILDES_/g (yes w/ an S so _TILDE_ still works) then restore them inside the while loop and don’t croak() here (maybe carp()) ?
    Carp::croak("Consecutive tildes are ambiguous (use the special placeholder _TILDE_ instead): “$phrase”") if $phrase =~ m/~~/;

    return [$phrase] unless $phrase =~ m/(?:$opening_bn|$closing_bn)/;

    my @struct;
    while (
        $phrase =~ m{
            ( # Capture chunk of …
                # bracket notation …
                (?:
                    $opening_bn
                        ( # Capture bracket pair contents
                            (?:
                            \~\]
                            |
                            [^\]]
                        )*
                    )
                $closing_bn
            )
            |
            # … or non-bracket notation
            (?:
                \~[\[\]]
                |
                [^\[\]]
            )+
        ) # /Capture chunk of …
    }gx
      ) {
        my ( $match, $bn_inside ) = ( $1, $2 );

        if ( defined $bn_inside ) {
            if ( $bn_inside =~ m/(?:$closing_bn|$opening_bn)/ ) {
                Carp::croak("Unbalanced bracket: “[$bn_inside]”");
            }

            my $list = [ _split_bn_cont($bn_inside) ];
            my $type = _get_bn_type_from_list($list);

            push @struct,
              {
                'orig' => $match,
                'cont' => $bn_inside,
                'list' => $list,
                'type' => $type,
              };
        }
        else {

            # probably won't trip but for good measure
            if ( $match =~ m/(?:$opening_bn|$closing_bn)/ ) {
                Carp::croak("Unbalanced bracket: “$match”");
            }

            push @struct, $match;
        }
    }

    return if !@struct;

    # if the structure rebuilds differently it means unbalanced [ or ] existed in $phrase that were masked out in @struct
    if ( struct2phrase( \@struct ) ne $phrase ) {
        Carp::croak("Unbalanced bracket: “$phrase”");
    }

    return \@struct;
}

sub struct2phrase {
    my ($struct) = @_;

    return join(
        '',
        map { ref($_) ? $_->{'orig'} : $_ } @{$struct}
    );
}

sub phrase_has_bracket_notation {
    return 1 if $_[0] =~ m/$opening_bn/;
    return;
}

sub struct_has_bracket_notation {
    my $len = @{ $_[0] };
    return 1 if ( $len == 1 && ref( $_[0]->[0] ) ) || $len > 1;
    return;
}

sub phrase_is_entirely_bracket_notation {
    return 1 if $_[0] =~ m{\A$opening_bn(?:\~[\[\]]|[^\[\]])+$closing_bn\z}x;
    return;
}

sub struct_is_entirely_bracket_notation {
    return 1 if @{ $_[0] } == 1 && ref( $_[0]->[0] );
    return;
}

sub _split_bn_cont {
    my ( $cont, $limit ) = @_;
    $limit = abs( int( $limit || 0 ) );
    return $limit ? split( $bn_delimit, $cont, $limit ) : split( $bn_delimit, $cont );
}

my %meth = (
    'numf'         => 'Should be passing in an unformatted number.',
    '#'            => 'Should be passing in an unformatted number (numf alias).',
    'format_bytes' => 'Should be passing in the unformatted number of bytes.',
    'output'       => sub {
        return 'Should be passing in character identifier.'                                                  if $_[0]->[1] eq 'chr';
        return 'Displayed without modification.'                                                             if $_[0]->[1] eq 'asis' || $_[0]->[1] eq 'asis_for_tests';
        return 'No args, character.'                                                                         if $_[0]->[1] =~ m/^(?:nbsp|amp|quot|apos|shy|lt|gt)/;
        return 'Domain should be passed in. Hardcoded domain that needs translated should just be a string.' if $_[0]->[1] eq 'encode_puny' || $_[0]->[1] eq 'decode_puny';
        return;
    },
    'datetime' => sub {
        return 'format has no translatable components' if !$_[0]->[2]    # there is no format (FWIW, 0 is not a valid format)
          || $_[0]->[2] =~ m/\A(?:date|time|datetime)_format_(:full|long|medium|short|default)\z/    # it is a format method name
          || $_[0]->[2] =~ m/\A[GgyYQqMmwWdDEeaAhHKkSszZvVuLFcj]+(?:{[0-9],?([0-9])?})?\z/;          # is only CLDR Pattern codes …

        # … i.e. which includes values for format_for() AKA $loc->available_formats(),
        #    http://search.cpan.org/perldoc?DateTime#CLDR_Patterns says:
        #       If you want to include any lower or upper case ASCII characters as-is, you can surround them with single quotes (').
        #        If you want to include a single quote, you must escape it as two single quotes ('').
        #        Spaces and any non-letter text will always be passed through as-is.

        return;
    },
    'current_year'    => 'Takes no args.',
    'asis'            => 'Displayed without modification.',
    'comment'         => 'Not displayed.',
    'join'            => 'Arbitrary args.',
    'sprintf'         => 'Arbitrary args.',
    'convert'         => 'Converts arbitrary units and identifiers.',    # ? technically USD -> GBP, not critical ATM ?
    'list_and'        => 'Arbitrary args.',
    'list_or'         => 'Arbitrary args.',
    'list_and_quoted' => 'Arbitrary args.',
    'list_or_quoted'  => 'Arbitrary args.',
    'list'            => 'Deprecated. Arbitrary args.',
);

my %basic = (
    'output'   => 'has possible translatable parts',
    'datetime' => 'has possible translatable components in format',
);

my %complex = (
    'url'        => 'should have translatable parts',
    'boolean'    => 'should have translatable parts',
    'is_defined' => 'should have translatable parts',
    'is_future'  => 'should have translatable parts',
    'quant'      => 'should have translatable parts',
    '*'          => 'should have translatable parts (quant alias)',
    'numerate'   => 'should have translatable parts',
);

my $ns_regexp = Module::Want::get_ns_regexp();

sub _get_attr_hash_from_list {
    my ( $list, $start_idx ) = @_;

    my $last_list_idx = @{$list} - 1;

    my %attr;
    my $skip_to = 0;
    for my $i ( $start_idx .. $last_list_idx ) {
        next if $i < $skip_to;
        next if $list->[$i] =~ m/\A$bn_var_arg\z/;

        $attr{ $list->[$i] } = $list->[ $i + 1 ];
        $skip_to = $i + 2;
    }

    return %attr;
}

sub _get_bn_type_from_list {
    my ($list) = @_;
    my $len = @{$list};

    return 'var' if $len == 1 && $list->[0] =~ m/\A$bn_var_arg\z/;

    # recommend to carp/croak
    return '_invalid' if !defined $list->[0] || $list->[0] !~ m/\A(?:$ns_regexp|\*|\#)\z/;
    return '_invalid' if $list->[0] eq 'output' && ( !defined $list->[1] || $list->[1] !~ m/\A$ns_regexp\z/ );

    # should not be anything translatable
    return 'meth' if exists $meth{ $list->[0] } && ( ref( $meth{ $list->[0] } ) ne 'CODE' || $meth{ $list->[0] }->($list) );

    if ( exists $basic{ $list->[0] } && ( ref( $basic{ $list->[0] } ) ne 'CODE' || $basic{ $list->[0] }->($list) ) ) {

        # check for 'basic_var' (might be basic except there are not any translatable parts)

        if ( $list->[0] eq 'output' ) {
            if ( $list->[1] =~ m/\A(?:underline|strong|em|class|attr|inline|block|sup|sub)\z/ ) {
                my %attr = _get_attr_hash_from_list( $list, 3 );

                if (   $list->[2] =~ m/\A$bn_var_arg\z/
                    && ( !exists $attr{'title'} || $attr{'title'} =~ m/\A$bn_var_arg\z/ )
                    && ( !exists $attr{'alt'}   || $attr{'alt'} =~ m/\A$bn_var_arg\z/ ) ) {
                    return 'basic_var';
                }
            }

            if ( $list->[1] =~ m/\A(?:img|abbr|acronym)\z/ ) {
                my %attr = _get_attr_hash_from_list( $list, 4 );

                # if any of these are true (except maybe $list->[2]) w/ these functions
                # then the caller is probably doing something wrong, the class/methods
                # will help find those sort of things better.
                if (   $list->[2] =~ m/\A$bn_var_arg\z/
                    && $list->[3] =~ m/\A$bn_var_arg\z/
                    && ( !exists $attr{'title'} || $attr{'title'} =~ m/\A$bn_var_arg\z/ )
                    && ( !exists $attr{'alt'}   || $attr{'alt'} =~ m/\A$bn_var_arg\z/ ) ) {
                    return 'basic_var';
                }
            }
        }

        return 'basic';
    }

    return 'complex' if exists $complex{ $list->[0] } && ( ref( $complex{ $list->[0] } ) ne 'CODE' || $complex{ $list->[0] }->($list) );
    return '_unknown';    # recommend to treat like 'basic' unless its one you know about that your class defines or if it's a show stopper
}

1;

__END__