File Coverage

blib/lib/String/Incremental/FormatParser.pm

Criterion	Covered	Total	%
statement	66	66	100.0
branch	24	24	100.0
condition			n/a
subroutine	11	11	100.0
pod	1	1	100.0
total	102	102	100.0

package String::Incremental::FormatParser;
use 5.008005;
use warnings;
use Mouse;
use Data::Validator;
use String::Incremental::Char;
use String::Incremental::String;
use MouseX::Types::Mouse qw( Str ArrayRef );
use String::Incremental::Types qw( CharOrderStr CharOrderArrayRef is_CharOrderStr );

has 'format' => ( is => 'ro', isa => Str );
has 'items'  => ( is => 'ro', isa => ArrayRef );

sub BUILDARGS {
    my ($class, @args) = @_;
    return _parse( @args );
}

sub _parse {
    my ($format, @rules) = @_;
    my $pf = _parse_format( $format );

    my $mismatch = ( grep {
        my $pos = $_->{pos};
        defined $pos ? ( defined $rules[$pos] ? 0 : 1 ) : 0;
    } @{$pf->{items}} ) ? 1 : 0;
    if ( $mismatch ) {
        my $msg = 'definition is mismatch: conversions v.s. rules';
        die $msg;
    }

    my @items;
    my $char_upper;
    for my $item ( @{$pf->{items}} ) {
        my $class = "String::Incremental::$item->{type}";
        my $obj;
        if ( $item->{type} eq 'Char' ) {
            $obj = $class->new(
                order => $rules[ $item->{pos} ],
                ( defined $char_upper ? ( upper => $char_upper ) : () ),
            );
            $char_upper = $obj;
        }
        else {
            $obj = $class->new(
                format => $item->{format},
                value  => ( defined $item->{pos} ? $rules[ $item->{pos} ] : '' ),
            );
        }
        push @items, $obj;
    }

    return +{
        format => $pf->{format},
        items  => \@items,
    };
}

sub _parse_format {
    my ($format) = @_;
    die 'no format is specified'  unless defined $format;

    my ($format_rpl, @items);

    ($format_rpl = $format) =~ s{%(\d+)?=}{
        my $n = $1;
        $n = 1 unless defined $n;
        join '', map '%s', (1..$n);
    }gex;

    my @conv = $format =~ /(%(?:\d+(?:\.?\d+)?)?\S)/g;
    my $pos = 0;
    for my $conv ( @conv ) {
        my ($dig, $type) = $conv =~ /%(\d+(?:\.?\d+)?)?(\S)/;
        if ( $type eq '=' ) {
            my $n = defined $dig ? $dig : 1;
            for ( 1 .. $n ) {
                push @items, +{ type => 'Char', pos => $pos };
            }
            $pos++;
        }
        elsif ( $type eq '%' ) {
            push @items, +{ type => 'String', format => $conv, pos => undef };
        }
        else {
            push @items, +{ type => 'String', format => $conv, pos => $pos };
            $pos++;
        }
    }

    return +{
        format     => $format_rpl,
        item_count => 0 + @items,
        items      => \@items,
    };
}

__PACKAGE__->meta->make_immutable();
__END__