523 lines
18 KiB
Perl
Executable File
523 lines
18 KiB
Perl
Executable File
package DDG::GoodieRole::Dates;
|
|
# ABSTRACT: A role to allow Goodies to recognize and work with dates in different notations.
|
|
|
|
use strict;
|
|
use warnings;
|
|
|
|
use Moo::Role;
|
|
|
|
use DateTime;
|
|
use Devel::StackTrace;
|
|
use List::Util qw( first );
|
|
use Package::Stash;
|
|
use Try::Tiny;
|
|
|
|
# This appears to parse most/all of the big ones, however it doesn't present a regex
|
|
use DateTime::Format::HTTP;
|
|
|
|
my %short_month_to_number = (
|
|
jan => 1,
|
|
feb => 2,
|
|
mar => 3,
|
|
apr => 4,
|
|
may => 5,
|
|
jun => 6,
|
|
jul => 7,
|
|
aug => 8,
|
|
sep => 9,
|
|
oct => 10,
|
|
nov => 11,
|
|
dec => 12,
|
|
);
|
|
|
|
# Reused lists and components for below
|
|
my $short_day_of_week = qr#Mon|Tue|Wed|Thu|Fri|Sat|Sun#i;
|
|
my $full_day_of_week = qr#Monday|Tuesday|Wednesday|Thursday|Friday|Saturday|Sunday#i;
|
|
my %full_month_to_short = map { lc $_ => substr($_, 0, 3) } qw(January February March April May June July August September October November December);
|
|
my %short_month_fix = map { lc $_ => $_ } (values %full_month_to_short);
|
|
my $short_month = qr#Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec#i;
|
|
my $full_month = qr#January|February|March|April|May|June|July|August|September|October|November|December#i;
|
|
my $month_regex = qr#$full_month|$short_month#;
|
|
my $time_24h = qr#(?:(?:[0-1][0-9])|(?:2[0-3]))[:]?[0-5][0-9][:]?[0-5][0-9]#i;
|
|
my $time_12h = qr#(?:(?:0[1-9])|(?:1[012])):[0-5][0-9]:[0-5][0-9]\s?(?:am|pm)#i;
|
|
my $date_number = qr#[0-3]?[0-9]#;
|
|
my $relative_dates = qr#
|
|
now | today | tomorrow | yesterday |
|
|
(?:(?:current|previous|next)\sday) |
|
|
(?:next|last|this)\s(?:week|month|year) |
|
|
(?:in\s(?:a|[0-9]+)\s(?:day|week|month|year)[s]?)(?:\stime)? |
|
|
(?:(?:a|[0-9]+)\s(?:day|week|month|year)[s]?\sago)
|
|
#ix;
|
|
|
|
# Covering the ambiguous formats, like:
|
|
# DMY: 27/11/2014 with a variety of delimiters
|
|
# MDY: 11/27/2014 -- fundamentally non-sensical date format, for americans
|
|
my $date_delim = qr#[\.\\/\,_-]#;
|
|
my $ambiguous_dates = qr#(?:$date_number)$date_delim(?:$date_number)$date_delim(?:[0-9]{4})#i;
|
|
my $ambiguous_dates_matches = qr#^(?<m>$date_number)$date_delim(?<d>$date_number)$date_delim(?<y>[0-9]{4})$#i;
|
|
|
|
# like: 1st 2nd 3rd 4-20,24-30th 21st 22nd 23rd 31st
|
|
my $number_suffixes = qr#(?:st|nd|rd|th)#i;
|
|
|
|
# Timezones: https://en.wikipedia.org/wiki/List_of_time_zone_abbreviations
|
|
my %tz_offsets = (
|
|
ACDT => '+1030',
|
|
ACST => '+0930',
|
|
ACT => '+0800',
|
|
ADT => '-0300',
|
|
AEDT => '+1100',
|
|
AEST => '+1000',
|
|
AFT => '+0430',
|
|
AKDT => '-0800',
|
|
AKST => '-0900',
|
|
AMST => '-0300',
|
|
AMT => '-0400',
|
|
ART => '-0300',
|
|
AST => '+0300',
|
|
AWDT => '+0900',
|
|
AWST => '+0800',
|
|
AZOST => '-0100',
|
|
AZT => '+0400',
|
|
BDT => '+0800',
|
|
BIOT => '+0600',
|
|
BIT => '-1200',
|
|
BOT => '-0400',
|
|
BRT => '-0300',
|
|
BST => '+0100',
|
|
BTT => '+0600',
|
|
CAT => '+0200',
|
|
CCT => '+0630',
|
|
CDT => '-0500',
|
|
CEDT => '+0200',
|
|
CEST => '+0200',
|
|
CET => '+0100',
|
|
CHADT => '+1345',
|
|
CHAST => '+1245',
|
|
CHOT => '+0800',
|
|
CHUT => '+1000',
|
|
CIST => '-0800',
|
|
CIT => '+0800',
|
|
CKT => '-1000',
|
|
CLST => '-0300',
|
|
CLT => '-0400',
|
|
COST => '-0400',
|
|
COT => '-0500',
|
|
CST => '-0600',
|
|
CT => '+0800',
|
|
CVT => '-0100',
|
|
CWST => '+0845',
|
|
CXT => '+0700',
|
|
ChST => '+1000',
|
|
DAVT => '+0700',
|
|
DDUT => '+1000',
|
|
DFT => '+0100',
|
|
EASST => '-0500',
|
|
EAST => '-0600',
|
|
EAT => '+0300',
|
|
ECT => '-0400',
|
|
EDT => '-0400',
|
|
EEDT => '+0300',
|
|
EEST => '+0300',
|
|
EET => '+0200',
|
|
EGST => '+0000',
|
|
EGT => '-0100',
|
|
EIT => '+0900',
|
|
EST => '-0500',
|
|
FET => '+0300',
|
|
FJT => '+1200',
|
|
FKST => '-0300',
|
|
FKT => '-0400',
|
|
FNT => '-0200',
|
|
GALT => '-0600',
|
|
GAMT => '-0900',
|
|
GET => '+0400',
|
|
GFT => '-0300',
|
|
GILT => '+1200',
|
|
GIT => '-0900',
|
|
GMT => '+0000',
|
|
GST => '-0200',
|
|
GYT => '-0400',
|
|
HADT => '-0900',
|
|
HAEC => '+0200',
|
|
HAST => '-1000',
|
|
HKT => '+0800',
|
|
HMT => '+0500',
|
|
HOVT => '+0700',
|
|
HST => '-1000',
|
|
ICT => '+0700',
|
|
IDT => '+0300',
|
|
IOT => '+0300',
|
|
IRDT => '+0430',
|
|
IRKT => '+0900',
|
|
IRST => '+0330',
|
|
IST => '+0530',
|
|
JST => '+0900',
|
|
KGT => '+0600',
|
|
KOST => '+1100',
|
|
KRAT => '+0700',
|
|
KST => '+0900',
|
|
LHST => '+1030',
|
|
LINT => '+1400',
|
|
MAGT => '+1200',
|
|
MART => '-0930',
|
|
MAWT => '+0500',
|
|
MDT => '-0600',
|
|
MEST => '+0200',
|
|
MET => '+0100',
|
|
MHT => '+1200',
|
|
MIST => '+1100',
|
|
MIT => '-0930',
|
|
MMT => '+0630',
|
|
MSK => '+0300',
|
|
MST => '-0700',
|
|
MUT => '+0400',
|
|
MVT => '+0500',
|
|
MYT => '+0800',
|
|
NCT => '+1100',
|
|
NDT => '-0230',
|
|
NFT => '+1130',
|
|
NPT => '+0545',
|
|
NST => '-0330',
|
|
NT => '-0330',
|
|
NUT => '-1100',
|
|
NZDT => '+1300',
|
|
NZST => '+1200',
|
|
OMST => '+0700',
|
|
ORAT => '-0500',
|
|
PDT => '-0700',
|
|
PET => '-0500',
|
|
PETT => '+1200',
|
|
PGT => '+1000',
|
|
PHOT => '+1300',
|
|
PKT => '+0500',
|
|
PMDT => '-0200',
|
|
PMST => '-0300',
|
|
PONT => '+1100',
|
|
PST => '-0800',
|
|
PYST => '-0300',
|
|
PYT => '-0400',
|
|
RET => '+0400',
|
|
ROTT => '-0300',
|
|
SAKT => '+1100',
|
|
SAMT => '+0400',
|
|
SAST => '+0200',
|
|
SBT => '+1100',
|
|
SCT => '+0400',
|
|
SGT => '+0800',
|
|
SLST => '+0530',
|
|
SRT => '-0300',
|
|
SST => '-1100',
|
|
SYOT => '+0300',
|
|
TAHT => '-1000',
|
|
TFT => '+0500',
|
|
THA => '+0700',
|
|
TJT => '+0500',
|
|
TKT => '+1300',
|
|
TLT => '+0900',
|
|
TMT => '+0500',
|
|
TOT => '+1300',
|
|
TVT => '+0500',
|
|
UCT => '+0000',
|
|
ULAT => '+0800',
|
|
UTC => '+0000',
|
|
UYST => '-0200',
|
|
UYT => '-0300',
|
|
UZT => '+0500',
|
|
VET => '-0430',
|
|
VLAT => '+1000',
|
|
VOLT => '+0400',
|
|
VOST => '+0600',
|
|
VUT => '+1100',
|
|
WAKT => '+1200',
|
|
WAST => '+0200',
|
|
WAT => '+0100',
|
|
WEDT => '+0100',
|
|
WEST => '+0100',
|
|
WET => '+0000',
|
|
WIT => '+0700',
|
|
WST => '+0800',
|
|
YAKT => '+1000',
|
|
YEKT => '+0600',
|
|
Z => '+0000',
|
|
);
|
|
my $tz_strings = join('|', keys %tz_offsets);
|
|
my $tz_suffixes = qr#(?:[+-][0-9]{4})|$tz_strings#i;
|
|
|
|
my $date_standard = qr#$short_day_of_week $short_month\s{1,2}$date_number $time_24h $tz_suffixes [0-9]{4}#i;
|
|
my $date_standard_matches = qr#$short_day_of_week (?<m>$short_month)\s{1,2}(?<d>$date_number) (?<t>$time_24h) (?<tz>$tz_suffixes) (?<y>[0-9]{4})#i;
|
|
|
|
# formats parsed by vague datestring, without colouring
|
|
# the context of the code using it
|
|
my $descriptive_datestring = qr{
|
|
(?:(?:next|last)\s(?:$month_regex)) | # next June, last jan
|
|
(?:(?:$month_regex)\s(?:[0-9]{4})) | # Jan 2014, August 2000
|
|
(?:(?:$date_number)\s?$number_suffixes?\s(?:$month_regex)) | # 18th Jan, 01 October
|
|
(?:(?:$month_regex)\s(?:$date_number)\s?$number_suffixes?) | # Dec 25, July 4th
|
|
(?:$month_regex) | # February, Aug
|
|
(?:$relative_dates) # next week, last month, this year
|
|
}ix;
|
|
|
|
# Used for parse_descriptive_datestring_to_date
|
|
my $descriptive_datestring_matches = qr#
|
|
(?:(?<q>next|last)\s(?<m>$month_regex)) |
|
|
(?:(?<m>$month_regex)\s(?<y>[0-9]{4})) |
|
|
(?:(?<d>$date_number)\s?$number_suffixes?\s(?<m>$month_regex)) |
|
|
(?:(?<m>$month_regex)\s(?<d>$date_number)\s?$number_suffixes?) |
|
|
(?<m>$month_regex) |
|
|
(?<r>$relative_dates)
|
|
#ix;
|
|
|
|
my $formatted_datestring = build_datestring_regex();
|
|
|
|
# Accessors for useful regexes
|
|
sub full_month_regex {
|
|
return $full_month;
|
|
}
|
|
sub short_month_regex {
|
|
return $short_month;
|
|
}
|
|
sub month_regex {
|
|
return $month_regex;
|
|
}
|
|
sub full_day_of_week_regex {
|
|
return $full_day_of_week;
|
|
}
|
|
sub short_day_of_week_regex {
|
|
return $short_day_of_week;
|
|
}
|
|
sub relative_dates_regex {
|
|
return $relative_dates;
|
|
}
|
|
|
|
# Accessors for matching regexes
|
|
# These matches are for "in the right format"/"looks about right"
|
|
# not "are valid dates"; expects normalised whitespace
|
|
sub datestring_regex {
|
|
return qr#$formatted_datestring|$descriptive_datestring#i;
|
|
}
|
|
|
|
sub descriptive_datestring_regex {
|
|
return $descriptive_datestring;
|
|
}
|
|
|
|
sub formatted_datestring_regex {
|
|
return $formatted_datestring;
|
|
}
|
|
|
|
# Called once to build $formatted_datestring
|
|
sub build_datestring_regex {
|
|
my @regexes = ();
|
|
|
|
## unambigous and awesome date formats:
|
|
# ISO8601: 2014-11-27 (with a concession to single-digit month and day numbers)
|
|
push @regexes, qr#[0-9]{4}-?[0-1]?[0-9]-?$date_number(?:[ T]$time_24h)?(?: ?$tz_suffixes)?#i;
|
|
|
|
# HTTP: Sat, 09 Aug 2014 18:20:00
|
|
push @regexes, qr#$short_day_of_week, [0-9]{2} $short_month [0-9]{4} $time_24h?#i;
|
|
|
|
# RFC850 08-Feb-94 14:15:29 GMT
|
|
push @regexes, qr#[0-9]{2}-$short_month-(?:[0-9]{2}|[0-9]{4}) $time_24h?(?: ?$tz_suffixes)#i;
|
|
|
|
# RFC2822 Sat, 13 Mar 2010 11:29:05 -0800
|
|
push @regexes, qr#$short_day_of_week, $date_number $short_month [0-9]{4} $time_24h $tz_suffixes#i;
|
|
|
|
# date(1) default format Sun Sep 7 15:57:56 EDT 2014
|
|
push @regexes, $date_standard;
|
|
|
|
# month-first date formats
|
|
push @regexes, qr#$date_number$date_delim$short_month$date_delim[0-9]{4}#i;
|
|
push @regexes, qr#$date_number$date_delim$full_month$date_delim[0-9]{4}#i;
|
|
push @regexes, qr#(?:$short_month|$full_month) $date_number(?: ?$number_suffixes)?[,]? [0-9]{4}#i;
|
|
|
|
# day-first date formats
|
|
push @regexes, qr#$short_month$date_delim$date_number$date_delim[0-9]{4}#i;
|
|
push @regexes, qr#$full_month$date_delim$date_number$date_delim[0-9]{4}#i;
|
|
push @regexes, qr#$date_number[,]?(?: ?$number_suffixes)? (?:$short_month|$full_month)[,]? [0-9]{4}#i;
|
|
|
|
## Ambiguous, but potentially valid date formats
|
|
push @regexes, $ambiguous_dates;
|
|
|
|
my $returned_regex = join '|', @regexes;
|
|
return qr/$returned_regex/i;
|
|
}
|
|
|
|
# Parses any string that *can* be parsed to a date object
|
|
sub parse_datestring_to_date {
|
|
my ($d,$base) = @_;
|
|
|
|
return parse_formatted_datestring_to_date($d) || parse_descriptive_datestring_to_date($d,$base);
|
|
}
|
|
|
|
# Accepts a string which looks like date per the supplied datestring_regex (e.g. '31/10/1980')
|
|
# Returns a DateTime object representing that date or `undef` if the string cannot be parsed.
|
|
sub parse_formatted_datestring_to_date {
|
|
my ($d) = @_;
|
|
|
|
return unless (defined $d && $d =~ qr/^$formatted_datestring$/); # Only handle white-listed strings, even if they might otherwise work.
|
|
if ($d =~ $ambiguous_dates_matches) {
|
|
# guesswork for ambigous DMY/MDY and switch to ISO
|
|
my ($month, $day, $year) = ($+{'m'}, $+{'d'}, $+{'y'}); # Assume MDY, even though it's crazy, for backward compatibility
|
|
|
|
if ($month > 12) {
|
|
# Months over 12 don't make any sense, so must not be MDY
|
|
return if ($day > 12); # what we took as day must not be month, either. No idea how to proceed.
|
|
($day, $month) = ($month, $day); # month and day must be swapped, then.
|
|
}
|
|
|
|
$d = sprintf("%04d-%02d-%02d", $year, $month, $day);
|
|
} elsif ($d =~ $date_standard_matches) {
|
|
# To ISO8601 for parsing
|
|
$d = sprintf('%04d-%02d-%02dT%s%s', $+{'y'}, $short_month_to_number{lc $+{'m'}}, $+{'d'}, $+{'t'}, $tz_offsets{$+{'tz'}});
|
|
}
|
|
|
|
$d =~ s/(\d+)\s?$number_suffixes/$1/i; # Strip ordinal text.
|
|
$d =~ s/,//i; # Strip any random commas.
|
|
$d =~ s/($full_month)/$full_month_to_short{lc $1}/i; # Parser deals better with the shorter month names.
|
|
$d =~ s/^($short_month)$date_delim(\d{1,2})/$2-$short_month_fix{lc $1}/i; # Switching Jun-01-2012 to 01 Jun 2012
|
|
|
|
my $maybe_date_object = try { DateTime::Format::HTTP->parse_datetime($d) }; # Don't die no matter how bad we did with checking our string.
|
|
|
|
return $maybe_date_object;
|
|
}
|
|
|
|
# parses multiple dates and guesses the consistent format over the set;
|
|
# i.e. defaults to m/d/y unless one of them is obviously d/m/y then it'll
|
|
# treat them all as d/m/y
|
|
sub parse_all_datestrings_to_date {
|
|
my @dates = @_;
|
|
|
|
# If there is an ambiguous date with a "month" over 12 in the set, we need to flip.
|
|
my $flip_d_m = first { /$ambiguous_dates_matches/ && $+{'m'} > 12 } @dates;
|
|
my @dates_to_return;
|
|
foreach my $date (@dates) {
|
|
if ($date =~ $ambiguous_dates_matches) {
|
|
my ($month, $day, $year) = ($+{'m'}, $+{'d'}, $+{'y'});
|
|
($day, $month) = ($month, $day) if $flip_d_m;
|
|
return if $month > 12; #there's a mish-mash of formats; give up
|
|
$date = "$year-$month-$day";
|
|
}
|
|
|
|
my $date_object = ($dates_to_return[0]
|
|
? parse_datestring_to_date($date, $dates_to_return[0])
|
|
: parse_datestring_to_date($date)
|
|
);
|
|
|
|
return unless $date_object;
|
|
push @dates_to_return, $date_object;
|
|
}
|
|
|
|
return @dates_to_return;
|
|
}
|
|
|
|
sub get_timezones {
|
|
return %tz_offsets;
|
|
}
|
|
|
|
sub _get_timezone {
|
|
my $default_tz = 'UTC'; # If any of the below fails for some reason, we'll go with this
|
|
|
|
my $tz = try {
|
|
# Dig through how we got here, ignoring
|
|
my $hit = 0;
|
|
# We only care about the most recent caller who is some kinda goodie-looking thing.
|
|
my $frame_filter = sub {
|
|
my $frame_info = shift;
|
|
if (!$hit && $frame_info->{caller}[0] =~ /^DDG::Goodie::/) { $hit++; return 1; }
|
|
else { return 0; }
|
|
};
|
|
my $trace = Devel::StackTrace->new(
|
|
frame_filter => $frame_filter,
|
|
no_args => 1,
|
|
);
|
|
my $stash = Package::Stash->new($trace->frame(0)->package); # Get the package info for our caller.
|
|
${$stash->get_symbol('$loc')}->time_zone; # Give back the time_zone in the $loc variable on their package
|
|
};
|
|
|
|
return $tz || $default_tz;
|
|
}
|
|
|
|
# Parses a really vague description and basically guesses
|
|
sub parse_descriptive_datestring_to_date {
|
|
my ($string, $base_time) = @_;
|
|
|
|
return unless (defined $string && $string =~ qr/^$descriptive_datestring_matches$/);
|
|
|
|
$base_time = DateTime->now(time_zone => _get_timezone()) unless($base_time);
|
|
my $month = $+{'m'}; # Set in each alternative match.
|
|
|
|
if (my $day = $+{'d'}) {
|
|
return parse_datestring_to_date("$day $month " . $base_time->year());
|
|
} elsif (my $relative_dir = $+{'q'}) {
|
|
my $tmp_date = parse_datestring_to_date("01 $month " . $base_time->year());
|
|
|
|
# for "next <month>"
|
|
$tmp_date->add( years => 1) if ($relative_dir eq "next" && DateTime->compare($tmp_date, $base_time) != 1);
|
|
# for "last <month>" if $tmp_date is in the future then we need to subtract a year
|
|
$tmp_date->add(years => -1) if ($relative_dir eq "last" && DateTime->compare($tmp_date, $base_time) != -1);
|
|
return $tmp_date;
|
|
} elsif (my $year = $+{'y'}) {
|
|
# Month and year is the first of that month.
|
|
return parse_datestring_to_date("01 $month $year");
|
|
} elsif (my $relative_date = $+{'r'}) {
|
|
# relative dates, tomorrow, yesterday etc
|
|
my $tmp_date = $base_time;
|
|
my @to_add;
|
|
if ($relative_date =~ qr/tomorrow|(?:next day)/) {
|
|
@to_add = (days => 1);
|
|
} elsif ($relative_date =~ qr/yesterday|(?:previous day)/) {
|
|
@to_add = (days => -1);
|
|
} elsif ($relative_date =~ qr/(?<dir>next|last|this) (?<unit>week|month|year)/) {
|
|
my $unit = $+{'unit'};
|
|
my $num = ($+{'dir'} eq 'next') ? 1 : ($+{'dir'} eq 'last') ? -1 : 0;
|
|
@to_add = _util_add_unit($unit, $num);
|
|
} elsif ($relative_date =~ qr/in (?<num>a|[0-9]+) (?<unit>day|week|month|year)/) {
|
|
my $unit = $+{'unit'};
|
|
my $num = ($+{'num'} eq "a" ? 1 : $+{'num'});
|
|
@to_add = _util_add_unit($unit, $num);
|
|
} elsif ($relative_date =~ qr/(?<num>a|[0-9]+) (?<unit>day|week|month|year)(?:[s])? ago/) {
|
|
my $unit = $+{'unit'};
|
|
my $num = ($+{'num'} eq "a" ? 1 : $+{'num'}) * -1;
|
|
@to_add = _util_add_unit($unit, $num);
|
|
}
|
|
# Any other cases which came through here should be today.
|
|
$tmp_date->add(@to_add);
|
|
return $tmp_date;
|
|
} else {
|
|
# single named months
|
|
# "january" in january means the current month
|
|
# otherwise it always means the coming month of that name, be it this year or next year
|
|
return parse_datestring_to_date("01 " . $base_time->month_name() . " " . $base_time->year()) if lc($base_time->month_name()) eq lc($month);
|
|
my $this_years_month = parse_datestring_to_date("01 $month " . $base_time->year());
|
|
$this_years_month->add(years => 1) if (DateTime->compare($this_years_month, $base_time) == -1);
|
|
return $this_years_month;
|
|
}
|
|
}
|
|
|
|
sub _util_add_unit {
|
|
my ($unit, $num) = @_;
|
|
my @to_add =
|
|
($unit eq 'day') ? (days => $num)
|
|
: ($unit eq 'week') ? (days => 7*$num)
|
|
: ($unit eq 'month') ? (months => $num)
|
|
: ($unit eq 'year') ? (years => $num)
|
|
: ();
|
|
return @to_add;
|
|
}
|
|
|
|
# Takes a DateTime object (or a string which can be parsed into one)
|
|
# and returns a standard formatted output string or an empty string if it cannot be parsed.
|
|
sub date_output_string {
|
|
my $dt = shift;
|
|
|
|
my $ddg_format = "%d %b %Y"; # Just here to make it easy to see.
|
|
my $string = ''; # By default we've got nothing.
|
|
# They didn't give us a DateTime object, let's try to make one from whatever we got.
|
|
$dt = parse_datestring_to_date($dt) if (ref($dt) !~ /DateTime/);
|
|
|
|
$string = $dt->strftime($ddg_format) if ($dt);
|
|
|
|
return $string;
|
|
}
|
|
|
|
1;
|