File Coverage

blib/lib/DateTime/Format/Natural/Formatted.pm

Criterion	Covered	Total	%
statement	115	124	92.7
branch	30	34	88.2
condition	18	30	60.0
subroutine	11	11	100.0
pod			n/a
total	174	199	87.4

package DateTime::Format::Natural::Formatted;

use strict;
use warnings;
use boolean qw(true false);

our $VERSION = '0.12';

sub _parse_formatted_ymd
{
    my $self = shift;
    my ($date_string, $count) = @_;

    my $date = $self->_split_formatted($date_string);

    my $date_sep = quotemeta((keys %$count)[0]);
    my @date_chunks = split /$date_sep/, $date;

    if ($date_chunks[1] =~ /^[a-zA-Z]+$/
      and my ($month_abbrev) = grep { $date_chunks[1] =~ /^${_}$/i } keys %{$self->{data}->{months_abbrev}}
    ) {
        my ($months_abbrev, $months) = map $self->{data}->{$_}, qw(months_abbrev months);
        $date_chunks[1] = sprintf '%02d', $months->{$months_abbrev->{$month_abbrev}};
    }

    my $i = 0;
    my %chunks_length = map { length $_ => $i++ } @date_chunks;

    my $format = lc $self->{Format};
    my $format_sep;

    my $lax = false;

    if (exists $chunks_length{4}) {
        $format = join $date_sep,
          ($chunks_length{4} == 0
            ? qw(yyyy mm dd)
            : ($format =~ /^m/
                ? qw(mm dd yyyy)
                : qw(dd mm yyyy)
              )
          );
        $lax = true;
    }
    elsif ($date_sep =~ /^\\[-.]$/ && $format !~ /$date_sep/) {
        $format = join $date_sep, qw(dd mm yy);
        $lax = true;
    }
    else {
        $format_sep = do { local $_ = $format;
                           tr/a-zA-Z//d;
                           tr/a-zA-Z//cs;
                           quotemeta; };
    }
    $format_sep ||= $date_sep;

    if (!$lax && $format_sep ne $date_sep) {
        $self->_set_failure;
        $self->_set_error("(mismatch between format and date separator)");
        return $self->_get_datetime_object;
    }

    my @format_order = split /$format_sep/, $format;

    my ($d, $m, $y) = do {
        my %f = map { substr($_, 0, 1) => true } @format_order;
        ($f{d}, $f{m}, $f{y});
    };
    unless (@format_order == 3 and $d && $m && $y) {
        $self->_set_failure;
        $self->_set_error("('format' parameter invalid)");
        return $self->_get_datetime_object;
    }

    $i = 0;
    my %format_index = map { substr($_, 0, 1) => $i++ } @format_order;

    my $century = $self->{datetime}
                ? int($self->{datetime}->year / 100)
                : substr((localtime)[5] + 1900, 0, 2);

    my ($day, $month, $year) = map $date_chunks[$format_index{$_}], qw(d m y);

    if (length $year == 2) { $year = "$century$year" };

    unless ($self->_check_date($year, $month, $day)) {
        $self->_set_failure;
        $self->_set_error("(invalid date)");
        return $self->_get_datetime_object;
    }

    $self->_set(
        year  => $year,
        month => $month,
        day   => $day,
    );
    $self->{datetime}->truncate(to => 'day');
    $self->_set_truncated;
    $self->_set_valid_exp;

    $self->_process_tokens;

    return undef;
}

sub _parse_formatted_md
{
    my $self = shift;
    my ($date_string) = @_;

    my $date = $self->_split_formatted($date_string);

    my @date_chunks = split /\//, $date;

    my $format = $self->{Format} =~ m{^[dm]{1,2}/[dm]{1,2}$}i
      ? do { local $_ = lc $self->{Format}; tr/dm//s; $_ }
      : undef;

    unless (defined $format && $format =~ m{^(?:(?:m/d)|(?:d/m))$}) {
        $self->_set_failure;
        $self->_set_error("('format' parameter invalid)");
        return $self->_get_datetime_object;
    }

    my $i = 0;
    my %format_index = map { $_ => $i++ } split /\//, $format;

    my ($day, $month) = map $date_chunks[$format_index{$_}], qw(d m);

    unless ($self->_check_date($self->{datetime}->year, $month, $day)) {
        $self->_set_failure;
        $self->_set_error("(invalid date)");
        return $self->_get_datetime_object;
    }

    $self->_set(
        month => $month,
        day   => $day,
    );
    $self->{datetime}->truncate(to => 'day');
    $self->_set_truncated;
    $self->_set_valid_exp;

    $self->_process_tokens;

    return undef;
}

sub _split_formatted
{
    my $self = shift;
    my ($date_string) = @_;

    my $date;
    if ($date_string =~ /^\S+\b \s+ \b\S+/x) {
        ($date, @{$self->{tokens}}) = split /\s+/, $date_string;
        $self->{count}{tokens} = 1 + @{$self->{tokens}};
    }
    else {
        $self->{count}{tokens} = 1;
    }

    return defined $date ? $date : $date_string;
}

sub _process_tokens
{
    my $self = shift;

    if (@{$self->{tokens}}) {
        $self->{count}{tokens}--;
        $self->_unset_truncated;
        $self->_unset_valid_exp;
        $self->_process;
    }
}

sub _count_separators
{
    my $self = shift;
    my ($formatted) = @_;

    my %count;
    if (defined $formatted) {
        my @count = $formatted =~ m![-./]!g;
        $count{$_}++ foreach @count;
    }

    return %count;
}

sub _check_formatted
{
    my $self = shift;
    my ($check, $count) = @_;

    my %checks = (
        ymd => sub
        {
            my ($count) = @_;
            return scalar keys %$count == 1 && $count->{(keys %$count)[0]} == 2;
        },
        md => sub
        {
            my ($count) = @_;
            return scalar keys %$count == 1 && $count->{(keys %$count)[0]} == 1 && (keys %$count)[0] eq '/';
        },
    );

    return $checks{$check}->($count);
}

1;
__END__

=head1 NAME

DateTime::Format::Natural::Formatted - Processing of formatted dates

=head1 SYNOPSIS

 Please see the DateTime::Format::Natural documentation.

=head1 DESCRIPTION

The C<DateTime::Format::Natural::Formatted> class contains methods
to parse formatted dates.

=head1 SEE ALSO

L<DateTime::Format::Natural>

=head1 AUTHOR

Steven Schubiger <[e-mail]>

=head1 LICENSE

This program is free software; you may redistribute it and/or
modify it under the same terms as Perl itself.

See L<http://dev.perl.org/licenses/>

=cut