File Coverage

blib/lib/DateTime/Format/Alami.pm

Criterion	Covered	Total	%
statement	239	337	70.9
branch	94	126	74.6
condition	26	42	61.9
subroutine	33	47	70.2
pod	3	28	10.7
total	395	580	68.1

package DateTime::Format::Alami;

our $DATE = '2016-06-30'; # DATE
our $VERSION = '0.13'; # VERSION

use 5.014000;
use strict;
use warnings;
use Log::Any::IfLOG '$log';

use Role::Tiny;

my @short_mons = qw(jan feb mar apr may jun jul aug sep oct nov dec);
my @dow = qw(monday tuesday wednesday thursday friday saturday sunday);

requires 'o_num';
requires '_parse_num';

requires 'w_year';
requires 'w_month';
requires 'w_week';
requires 'w_day';
requires 'w_hour';
requires 'w_minute';
requires 'w_second';

requires "w_$_" for @short_mons;
requires "w_$_" for @dow;

requires 'p_now';
requires 'p_today';
requires 'p_yesterday';
requires 'p_tomorrow';
requires 'p_dateymd';
requires 'o_date';
requires 'p_dur_ago';
requires 'p_dur_later';
requires 'p_which_dow';
requires 'p_time';
requires 'p_date_time';

our ($m, $o);
sub new {
    my $class = shift;
    if ($class eq __PACKAGE__) {
        die "Use one of the DateTime::Format::Alami::* instead, ".
            "e.g. DateTime::Format::Alami::EN";
    }
    my $self = bless {}, $class;
    no strict 'refs';
    unless (${"$class\::RE_DT"} && ${"$class\::RE_DUR"}) {
        require Class::Inspector;
        require Data::Graph::Util;

        my $meths = Class::Inspector->methods($class);
        my %pats;  # key = "p_..."
        my %pat_lengths; # key = "p_..."
        my %graph;
        for my $meth (@$meths) {
            next unless $meth =~ /^(odur|o|pdur|p)_/;
            my $pat = $self->$meth;
            my $is_p    = $meth =~ /^p_/;
            my $is_pdur = $meth =~ /^pdur_/;
            $pat =~ s/<(\w+)>/push @{$graph{$meth}}, $1; "(?\&$1)"/eg;
            my $action_meth = $meth;
            if ($is_pdur) { $action_meth =~ s/^pdur_/adur_/ } else { $action_meth =~ s/^p_/a_/ }
            #my $before_meth = $meth; $before_meth =~ s/^p_/before_p_/;
            #$before_meth = undef unless $is_p && $self->can($before_meth);
            $pat = join(
                "",
                "(",
                #($before_meth ? "(?{ ".($ENV{DEBUG} ? "say \"invoking $before_meth()\";" : "")."\$DateTime::Format::Alami::o->$before_meth(\$DateTime::Format::Alami::m) })" : ""),
                ($is_p || $is_pdur ? "\\b $pat \\b" : $pat), ")",

                # we capture ourselves instead of relying on named capture
                # because subpattern capture are discarded
                "(?{ \$DateTime::Format::Alami::m->{$meth} = \$^N })",

                ($is_p || $is_pdur ? "(?{ ".($ENV{DEBUG} ? "say \"invoking $action_meth(\$^N)\";" : "")."\$DateTime::Format::Alami::o->{_pat} = \"$meth\"; \$DateTime::Format::Alami::o->$action_meth(\$DateTime::Format::Alami::m) })" : ""),
            );
            $pats{$meth} = $pat;
            $pat_lengths{$meth} = length($pat);
        }
        my @pat_names_by_deps = Data::Graph::Util::toposort(\%graph);
        my %pat_name_dep_orders = map { $pat_names_by_deps[$_] => $_ }
            0..$#pat_names_by_deps;
        my @pat_names = sort {(
            ($pat_name_dep_orders{$a} // 9999) <=>
                ($pat_name_dep_orders{$b} // 9999)
                ||
                $pat_lengths{$b} <=> $pat_lengths{$a}) } keys %pats;
        my $nl = $ENV{DEBUG} ? "\n" : "";
        my $re_dt = join(
            "",
            "(?&top)", $nl,
            #"(?&p_dateymd)", $nl, # testing
            "(?(DEFINE)", $nl,
            "(?", join("|",
                            map {"(?&$_)"} grep {/^p_/} @pat_names), ")$nl",
            (map { "(?<$_> $pats{$_})$nl" } grep {/^(o|p)_/} @pat_names),
            ")", # end of define
        );
        my $re_dur = join(
            "",
            "(?&top)", $nl,
            #"(?&pdur_dur)", $nl, # testing
            "(?(DEFINE)", $nl,
            "(?", join("|",
                            map {"(?&$_)"} grep {/^pdur_/} @pat_names), ")$nl",
            (map { "(?<$_> $pats{$_})$nl" } grep {/^(odur|pdur)_/} @pat_names),
            ")", # end of define
        );
        {
            use re 'eval';
            ${"$class\::RE_DT"}  = qr/$re_dt/ix;
            ${"$class\::RE_DUR"} = qr/$re_dur/ix;
        }
    }
    unless (${"$class\::MAPS"}) {
        my $maps = {};
        # month names -> num
        {
            my $i = 0;
            for my $m (@short_mons) {
                ++$i;
                my $meth = "w_$m";
                for (@{ $self->$meth }) {
                    $maps->{months}{$_} = $i;
                }
            }
        }
        # day-of-week names -> num (monday=1, sunday=7)
        {
            my $i = 0;
            for my $m (@dow) {
                ++$i;
                my $meth = "w_$m";
                for (@{ $self->$meth }) {
                    $maps->{dow}{$_} = $i;
                }
            }
        }
        ${"$class\::MAPS"} = $maps;
    }

    # _time_zone is old name (<= 0.11) will be removed later
    $self->{time_zone} //= $self->{_time_zone};

    $self;
}

sub _reset {
    my $self = shift;
    undef $self->{_pat};
    undef $self->{_dt};
    undef $self->{_uses_time};
}

sub parse_datetime {
    no strict 'refs';

    # we require DateTime here, for all the a_* methods
    require DateTime;

    my ($self, $str, $opts) = @_;

    # allow calling as static method
    unless (ref $self) { $self = $self->new }

    $opts //= {};
    $opts->{format} //= 'DateTime';
    #$opts->{prefers} //= 'nearest';
    $opts->{returns} //= 'first';

    local $self->{time_zone} = $opts->{time_zone} if $opts->{time_zone};

    # we need /o to avoid repeated regcomp, but we need to make it work with all
    # subclasses, so we use eval() here.
    unless (defined *{ref($self).'::_code_match_dt'}) {
        *{ref($self).'::_code_match_dt'} = eval "sub { \$_[0] =~ /(\$".ref($self)."::RE_DT)/go; \$1 }";
        die if $@;
    }

    $o = $self;
    my @res;
    while (1) {
        $o->_reset;
        $m = {};
        my $match = &{ref($self).'::_code_match_dt'}($str) or last;
        $o->{_dt}->truncate(to=>'day') unless $o->{_uses_time};
        my $res = {
            verbatim => $match,
            pattern => $o->{_pat},
            pos => pos($str) - length($match),
            m => {%$m},
        };
        $res->{uses_time} = $o->{_uses_time} ? 1:0;
        $res->{DateTime}  = $o->{_dt};
        $res->{epoch}     = $o->{_dt}->epoch if
            $opts->{format} eq 'combined' || $opts->{format} eq 'epoch';
        push @res, $res;
        last if $opts->{returns} eq 'first';
    }

    die "Can't parse date '$str'" unless @res;

    @res = ($res[-1]) if $opts->{returns} eq 'last';

    if ($opts->{returns} =~ /\A(?:all_cron|earliest|latest)\z/) {
        # sort chronologically, note that by this time the DateTime module
        # should already have been loaded
        @res = sort {
            DateTime->compare($a->{DateTime}, $b->{DateTime})
        } @res;
    }

    if ($opts->{format} eq 'DateTime') {
        @res = map { $_->{DateTime} } @res;
    } elsif ($opts->{format} eq 'epoch') {
        @res = map { $_->{epoch} } @res;
    } elsif ($opts->{format} eq 'verbatim') {
        @res = map { $_->{verbatim} } @res;
    }

    if ($opts->{returns} =~ /\A(?:all|all_cron)\z/) {
        return \@res;
    } elsif ($opts->{returns} =~ /\A(?:first|earliest)\z/) {
        return $res[0];
    } elsif ($opts->{returns} =~ /\A(?:last|latest)\z/) {
        return $res[-1];
    } else {
        die "Unknown returns option '$opts->{returns}'";
    }
}

sub _reset_dur {
    my $self = shift;
    undef $self->{_pat};
    undef $self->{_dtdur};
}

sub parse_datetime_duration {
    # we require DateTime here, for all the adur_* methods
    require DateTime;
    require DateTime::Duration;

    no strict 'refs';

    my ($self, $str, $opts) = @_;

    # allow calling as static method
    unless (ref $self) { $self = $self->new }

    $opts //= {};
    $opts->{format}  //= 'Duration';
    $opts->{returns} //= 'first';

    # we need /o to avoid repeated regcomp, but we need to make it work with all
    # subclasses, so we use eval() here.
    unless (defined *{ref($self).'::_code_match_dur'}) {
        *{ref($self).'::_code_match_dur'} = eval "sub { \$_[0] =~ /(\$".ref($self)."::RE_DUR)/go; \$1 }";
        die if $@;
    }

    $o = $self;
    my @res;
    while (1) {
        $o->_reset_dur;
        $m = {};
        my $match = &{ref($self).'::_code_match_dur'}($str) or last;
        my $res = {
            verbatim => $match,
            pattern => $o->{_pat},
            pos => pos($str) - length($match),
            m => {%$m},
        };
        $res->{Duration}  = $o->{_dtdur};
        if ($opts->{format} eq 'combined' || $opts->{format} eq 'seconds') {
            my $d = $o->{_dtdur};
            $res->{seconds} =
                $d->years       *   365.25*86400 +
                $d->months      *  30.4375*86400 +
                $d->weeks       *        7*86400 +
                $d->days        *          86400 +
                $d->hours       *           3600 +
                $d->minutes     *             60 +
                $d->seconds                      +
                $d->nanoseconds *           1e-9;
        }
        push @res, $res;
        last if $opts->{returns} eq 'first';
    }

    die "Can't parse duration" unless @res;

    @res = ($res[-1]) if $opts->{returns} eq 'last';

    # XXX support returns largest, smallest, all_sorted
    if ($opts->{returns} =~ /\A(?:all_sorted|largest|smallest)\z/) {
        my $base_dt = DateTime->now;
        # sort from smallest to largest
        @res = sort {
            DateTime::Duration->compare($a->{Duration}, $b->{Duration}, $base_dt)
          } @res;
    }

    if ($opts->{format} eq 'Duration') {
        @res = map { $_->{Duration} } @res;
    } elsif ($opts->{format} eq 'seconds') {
        @res = map { $_->{seconds} } @res;
    } elsif ($opts->{format} eq 'verbatim') {
        @res = map { $_->{verbatim} } @res;
    }

    if ($opts->{returns} =~ /\A(?:all|all_sorted)\z/) {
        return \@res;
    } elsif ($opts->{returns} =~ /\A(?:first|smallest)\z/) {
        return $res[0];
    } elsif ($opts->{returns} =~ /\A(?:last|largest)\z/) {
        return $res[-1];
    } else {
        die "Unknown returns option '$opts->{returns}'";
    }
}

sub o_dayint { "(?:[12][0-9]|3[01]|0?[1-9])" }

sub o_monthint { "(?:0?[1-9]|1[012])" }

sub o_yearint { "(?:[0-9]{4}|[0-9]{2})" }

sub o_hour { "(?:[0-9][0-9]?)" }

sub o_minute { "(?:[0-9][0-9]?)" }

sub o_second { "(?:[0-9][0-9]?)" }

sub o_monthname {
    my $self = shift;
    "(?:" . join(
        "|",
        (map {my $meth="w_$_"; @{ $self->$meth }} @short_mons)
    ) . ")";
}

sub o_dow {
    my $self = shift;
    "(?:" . join(
        "|",
        (map {my $meth="w_$_"; @{ $self->$meth }} @dow)
    ) . ")";
}

sub o_durwords  {
    my $self = shift;
    "(?:" . join(
        "|",
        @{ $self->w_year }, @{ $self->w_month }, @{ $self->w_week },
        @{ $self->w_day },
        @{ $self->w_hour }, @{ $self->w_minute }, @{ $self->w_second },
    ) . ")";
}

sub o_dur {
    my $self = shift;
    "(?:(" . $self->o_num . "\\s*" . $self->o_durwords . "\\s*(?:,\\s*)?)+)";
}

sub odur_dur {
    my $self = shift;
    $self->o_dur;
}

sub pdur_dur {
    my $self = shift;
    "(?:)";
}

# durations less than a day
sub o_timedurwords  {
    my $self = shift;
    "(?:" . join(
        "|",
        @{ $self->w_hour }, @{ $self->w_minute }, @{ $self->w_second },
    ) . ")";
}

sub o_timedur {
    my $self = shift;
    "(?:(" . $self->o_num . "\\s*" . $self->o_timedurwords . "\\s*(?:,\\s*)?)+)";
}

sub _parse_dur {
    use experimental 'smartmatch';

    my ($self, $str) = @_;

    #say "D:dur=$str";
    my %args;
    unless ($self->{_cache_re_parse_dur}) {
        my $o_num = $self->o_num;
        my $o_dw  = $self->o_durwords;
        $self->{_cache_re_parse_dur} = qr/($o_num)\s*($o_dw)/ix;
    }
    unless ($self->{_cache_w_second}) {
        $self->{_cache_w_second} = $self->w_second;
        $self->{_cache_w_minute} = $self->w_minute;
        $self->{_cache_w_hour}   = $self->w_hour;
        $self->{_cache_w_day}    = $self->w_day;
        $self->{_cache_w_week}   = $self->w_week;
        $self->{_cache_w_month}  = $self->w_month;
        $self->{_cache_w_year}   = $self->w_year;
    }
    while ($str =~ /$self->{_cache_re_parse_dur}/g) {
        my ($n, $unit) = ($1, $2);
        $n = $self->_parse_num($n);
        if ($unit ~~ $self->{_cache_w_second}) {
            $args{seconds} = $n;
            $self->{_uses_time} = 1;
        } elsif ($unit ~~ $self->{_cache_w_minute}) {
            $args{minutes} = $n;
            $self->{_uses_time} = 1;
        } elsif ($unit ~~ $self->{_cache_w_hour}) {
            $args{hours} = $n;
            $self->{_uses_time} = 1;
        } elsif ($unit ~~ $self->{_cache_w_day}) {
            $args{days} = $n;
        } elsif ($unit ~~ $self->{_cache_w_week}) {
            $args{weeks} = $n;
        } elsif ($unit ~~ $self->{_cache_w_month}) {
            $args{months} = $n;
        } elsif ($unit ~~ $self->{_cache_w_year}) {
            $args{years} = $n;
        }
    }
    DateTime::Duration->new(%args);
}

sub _now_if_unset {
    my $self = shift;
    $self->a_now unless $self->{_dt};
}

sub _today_if_unset {
    my $self = shift;
    $self->a_today unless $self->{_dt};
}

sub a_now {
    my $self = shift;
    $self->{_dt} = DateTime->now(
        (time_zone => $self->{time_zone}) x !!defined($self->{time_zone}),
    );
    $self->{_uses_time} = 1;
}

sub a_today {
    my $self = shift;
    $self->{_dt} = DateTime->today(
        (time_zone => $self->{time_zone}) x !!defined($self->{time_zone}),
    );
    $self->{_uses_time} = 0;
}

sub a_yesterday {
    my $self = shift;
    $self->a_today;
    $self->{_dt}->subtract(days => 1);
}

sub a_tomorrow {
    my $self = shift;
    $self->a_today;
    $self->{_dt}->add(days => 1);
}

sub a_dateymd {
    my ($self, $m) = @_;
    $self->a_today;
    if (defined $m->{o_yearint}) {
        my $year;
        if (length($m->{o_yearint}) == 2) {
            my $start_of_century_year = int($self->{_dt}->year / 100) * 100;
            $year = $start_of_century_year + $m->{o_yearint};
        } else {
            $year = $m->{o_yearint};
        }
        $self->{_dt}->set_year($year);
    }
    if (defined $m->{o_dayint}) {
        $self->{_dt}->set_day($m->{o_dayint});
    }
    if (defined $m->{o_monthint}) {
        $self->{_dt}->set_month($m->{o_monthint});
    }
    if (defined $m->{o_monthname}) {
        no strict 'refs';
        my $maps = ${ ref($self) . '::MAPS' };
        $self->{_dt}->set_month($maps->{months}{lc $m->{o_monthname}});
    }
}

sub a_which_dow {
    no strict 'refs';

    my ($self, $m) = @_;
    $self->a_today;
    my $dow_num = $self->{_dt}->day_of_week;

    my $maps = ${ ref($self) . '::MAPS' };
    my $wanted_dow_num = $maps->{dow}{lc $m->{o_dow} };

    $self->{_dt}->add(days => ($wanted_dow_num-$dow_num));

    if ($m->{offset}) {
        $self->{_dt}->add(days => (7*$m->{offset}));
    }
}

sub adur_dur {
    my ($self, $m) = @_;
    $self->{_dtdur} = $self->_parse_dur($m->{odur_dur});
}

sub a_dur_ago {
    my ($self, $m) = @_;
    $self->a_now;
    my $dur = $self->_parse_dur($m->{o_dur});
    $self->{_dt}->subtract_duration($dur);
}

sub a_dur_later {
    my ($self, $m) = @_;
    $self->a_now;
    my $dur = $self->_parse_dur($m->{o_dur});
    $self->{_dt}->add_duration($dur);
}

sub a_time {
    my ($self, $m) = @_;
    $self->_now_if_unset;
    $self->{_uses_time} = 1;
    my $hour = $m->{o_hour};
    if ($m->{o_ampm}) {
        $hour += 12 if lc($m->{o_ampm}) eq 'pm' && $hour < 12;
        $hour =  0  if lc($m->{o_ampm}) eq 'am' && $hour == 12;
    }
    $self->{_dt}->set_hour($hour);
    $self->{_dt}->set_minute($m->{o_minute});
    $self->{_dt}->set_second($m->{o_second} // 0);
}

sub a_date_time {
    my ($self, $m) = @_;
}

1;
# ABSTRACT: Parse human date/time expression (base class)

__END__