Date::Extract - extract probable dates from strings

    my $parser = Date::Extract->new();
    my $dt = $parser->extract($arbitrary_text)
        or die "No date found.";
    return $dt->ymd;

package Date::Extract;
use strict;
use warnings;
use DateTime::Format::Natural;
use List::Util 'reduce';
use parent 'Class::Data::Inheritable';

our $VERSION = '0.04';

__PACKAGE__->mk_classdata($_) for qw/scalar_downgrade handlers regex/;

sub _croak {
    require Carp;
    Carp::croak @_;
}

sub new {
    my $class = shift;
    my %args = (
        returns => 'first',
        prefers => 'nearest',
        time_zone => 'floating',
        @_,
    );

    if ($args{returns} ne 'first'
     && $args{returns} ne 'last'
     && $args{returns} ne 'earliest'
     && $args{returns} ne 'latest'
     && $args{returns} ne 'all'
     && $args{returns} ne 'all_cron') {
        _croak "Invalid `returns` passed to constructor: expected `first', `last', `earliest', `latest', `all', or `all_cron'.";
    }

    if ($args{prefers} ne 'nearest'
     && $args{prefers} ne 'past'
     && $args{prefers} ne 'future') {
        _croak "Invalid `prefers` passed to constructor: expected `nearest', `past', or `future'.";
    }

    my $self = bless \%args, ref($class) || $class;

    return $self;
}

# This method will combine the arguments of parser->new and extract. Modify the
# "to" hash directly.

sub _combine_args {
    shift;

    my $from = shift;
    my $to = shift;

    $to->{prefers}   ||= $from->{prefers};
    $to->{returns}   ||= $from->{returns};
    $to->{time_zone} ||= $from->{time_zone};
}

sub extract {
    my $self = shift;
    my $text = shift;
    my %args = @_;

    # using extract as a class method
    $self = $self->new
        if !ref($self);

    # combine the arguments of parser->new and this
    $self->_combine_args($self, \%args);

    # when in scalar context, downgrade
    $args{returns} = $self->_downgrade($args{returns})
        unless wantarray;

    # do the work
    my @ret = $self->_extract($text, %args);

    # munge the output to match the desired return type
    return $self->_handle($args{returns}, @ret);
}

# build the giant regex used for parsing. it has to be a single regex, so that
# the order of matches is correct.
sub _build_regex {
    my $self = shift;

    my $relative          = '(?:today|tomorrow|yesterday)';

    my $long_weekday      = '(?:Monday|Tuesday|Wednesday|Thursday|Friday|Saturday|Sunday)';
    my $short_weekday     = '(?:Mon|Tue|Wed|Thu|Fri|Sat|Sun)';
    my $weekday           = "(?:$long_weekday|$short_weekday)";

    my $relative_weekday  = "(?:(?:next|previous|last)\\s*$weekday)";

    my $long_month        = '(?:January|February|March|April|May|June|July|August|September|October|November|December)';
    my $short_month       = '(?:Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec)';
    my $month             = "(?:$long_month|$short_month)";

    # 1 - 31
    my $cardinal_monthday = "(?:[1-9]|[12][0-9]|3[01])";
    my $monthday          = "(?:$cardinal_monthday(?:st|nd|rd|th)?)";

    my $day_month         = "(?:$monthday\\s*$month)";
    my $month_day         = "(?:$month\\s*$monthday)";
    my $day_month_year    = "(?:(?:$day_month|$month_day)\\s*,\\s*\\d\\d\\d\\d)";

    my $yyyymmdd          = "(?:\\d\\d\\d\\d[-/]\\d\\d[-/]\\d\\d)";
    my $ddmmyy            = "(?:\\d\\d[-/]\\d\\d[-/]\\d\\d)";
    my $ddmmyyyy          = "(?:\\d\\d[-/]\\d\\d[-/]\\d\\d\\d\\d)";

    my $other             = $self->_build_more_regex;
    $other = "|$other"
        if $other;

    my $regex = qr{
                \b(
                        $relative         # today
                    | $relative_weekday # last Friday
                    | $weekday          # Monday
                    | $day_month_year   # November 13th, 1986
                    | $day_month        # November 13th
                    | $month_day        # 13 Nov
                    | $yyyymmdd         # 1986/11/13
                    | $ddmmyy           # 11-13-86
                    | $ddmmyyyy         # 11-13-1986
                        $other            # anything from the subclass
                )\b
        }ix;

    $self->regex($regex);
}

# this is to be used in subclasses for adding more stuff to the regex
# for example, to add support for $foo_bar and $baz_quux, return
# "$foo_bar|$baz_quux"
sub _build_more_regex { '' }

# build the list->scalar downgrade types
sub _build_scalar_downgrade {
    my $self = shift;

    $self->scalar_downgrade({
        all      => 'first',
        all_cron => 'earliest',
    });
}

# build the handlers that munge the list of dates to the desired order
sub _build_handlers {
    my $self = shift;

    $self->handlers({
        all_cron => sub {
            sort { DateTime->compare_ignore_floating($a, $b) } @_
        },
        all      => sub { @_ },

        earliest => sub { reduce { $a < $b ? $a : $b } @_ },
        latest   => sub { reduce { $a > $b ? $a : $b } @_ },
        first    => sub { $_[0]  },
        last     => sub { $_[-1] },
    });
}

# actually perform the scalar downgrade
sub _downgrade {
    my $self    = shift;
    my $returns = shift;

    my $downgrades = $self->scalar_downgrade || $self->_build_scalar_downgrade;
    return $downgrades->{$returns} || $returns;
}

sub _handle {
    my $self    = shift;
    my $returns = shift;

    my $handlers = $self->handlers || $self->_build_handlers;
    my $handler = $handlers->{$returns};
    return defined $handler ? $handler->(@_) : @_
}

sub _extract {
    my $self = shift;
    my $text = shift;
    my %args = @_;

    my $regex = $self->regex || $self->_build_regex;
    my @gleaned = $text =~ /$regex/g;

    my %dtfn_args;
    $dtfn_args{prefer_future} = 1
        if $args{prefers} && $args{prefers} eq 'future';
    $dtfn_args{time_zone} = $args{time_zone};

    my $parser = DateTime::Format::Natural->new(%dtfn_args);
    my @ret;
    for (@gleaned) {
        my $dt = $parser->parse_datetime($_);
        push @ret, $dt->set_time_zone($args{time_zone})
            if $parser->success;
    }

    return @ret;
}

1;

__END__