DateTime::Format::Natural::Duration
DateTime::Format::Natural::Expand
DateTime::Format::Natural::Extract
DateTime::Format::Natural::Formatted
DateTime::Format::Natural::Helpers
DateTime::Format::Natural::Rewrite
);
our $VERSION = '1.20';
validation_options(
on_fail => sub
{
my ($error) = @_;
chomp $error;
croak $error;
},
stack_skip => 2,
);
sub new
{
my $class = shift;
my $self = bless {}, ref($class) || $class;
$self->_init_check(@_);
$self->_init(@_);
return $self;
}
sub _init
{
my $self = shift;
my %opts = @_;
my %presets = (
lang => 'en',
format => 'd/m/y',
demand_future => false,
prefer_future => false,
time_zone => 'floating',
);
foreach my $opt (keys %presets) {
$self->{ucfirst $opt} = $presets{$opt};
}
foreach my $opt (keys %opts) {
if (defined $opts{$opt}) {
$self->{ucfirst $opt} = $opts{$opt};
}
}
$self->{Daytime} = $opts{daytime} || {};
my $mod = join '::', (__PACKAGE__, 'Lang', uc $self->{Lang});
eval "require $mod" or die $@;
$self->{data} = $mod->__new();
$self->{grammar_class} = $mod;
$self->{mode} = '';
}
sub _init_check
{
my $self = shift;
validate(@_, {
demand_future => {
type => BOOLEAN | SCALARREF,
optional => true,
callbacks => {
'mutually exclusive' => sub
{
return true unless exists $_[1]->{prefer_future};
die "prefer_future provided\n";
},
},
},
lang => {
type => SCALAR,
optional => true,
regex => qr!^(?:en)$!i,
},
format => {
type => SCALAR,
optional => true,
regex => qr!^(?:
(?: (?: [dmy]{1,4}[-./] ){2}[dmy]{1,4} )
|
(?: [dm]{1,2}/[dm]{1,2} )
)$!ix,
},
prefer_future => {
type => BOOLEAN | SCALARREF,
optional => true,
callbacks => {
'mutually exclusive' => sub
{
return true unless exists $_[1]->{demand_future};
die "demand_future provided\n";
},
},
},
time_zone => {
type => SCALAR | OBJECT,
optional => true,
callbacks => {
'valid timezone' => sub
{
my $val = shift;
if (blessed($val)) {
return $val->isa('DateTime::TimeZone');
}
else {
eval { DateTime::TimeZone->new(name => $val) };
return !$@;
}
}
},
},
daytime => {
type => HASHREF,
optional => true,
callbacks => {
'valid daytime' => sub
{
my $href = shift;
my %daytimes = map { $_ => true } qw(morning afternoon evening);
if (any { !$daytimes{$_} } keys %$href) {
die "spelling of daytime\n";
}
elsif (any { !defined $href->{$_} } keys %$href) {
die "undefined hour\n";
}
elsif (any { $href->{$_} !~ /^\d{1,2}$/ } keys %$href) {
die "not a valid number\n";
}
elsif (any { $href->{$_} < 0 || $href->{$_} > 23 } keys %$href) {
die "hour out of range\n";
}
else {
return true;
}
}
},
},
datetime => {
type => OBJECT,
optional => true,
callbacks => {
'valid object' => sub
{
my $obj = shift;
blessed($obj) && $obj->isa('DateTime');
}
},
},
});
}
sub _init_vars
{
my $self = shift;
delete @$self{qw(keyword modified postprocess)};
}
sub parse_datetime
{
my $self = shift;
$self->_parse_init(@_);
$self->{input_string} = $self->{date_string};
$self->{mode} = 'parse';
my $date_string = $self->{date_string};
$self->_rewrite(\$date_string);
my ($formatted) = $date_string =~ $self->{data}->__regexes('format');
my %count = $self->_count_separators($formatted);
$self->{tokens} = [];
$self->{traces} = [];
if ($self->_check_formatted('ymd', \%count)) {
my $dt = $self->_parse_formatted_ymd($date_string, \%count);
return $dt if blessed($dt);
}
elsif ($self->_check_formatted('md', \%count)) {
my $dt = $self->_parse_formatted_md($date_string);
return $dt if blessed($dt);
if ($self->{Prefer_future} || $self->{Demand_future}) {
$self->_advance_future('md');
}
}
elsif ($date_string =~ /^(\d{4}(?:-\d{2}){0,2})T(\d{2}(?::\d{2}){0,2})$/) {
my ($date, $time) = ($1, $2);
my %args;
@args{qw(year month day)} = split /-/, $date;
$args{$_} ||= 01 foreach qw(month day);
@args{qw(hour minute second)} = split /:/, $time;
$args{$_} ||= 00 foreach qw(minute second);
my $valid_date = $self->_check_date(map $args{$_}, qw(year month day));
my $valid_time = $self->_check_time(map $args{$_}, qw(hour minute second));
if (not $valid_date && $valid_time) {
my $type = !$valid_date ? 'date' : 'time';
$self->_set_failure;
$self->_set_error("(invalid $type)");
return $self->_get_datetime_object;
}
$self->_set(%args);
$self->{datetime}->truncate(to => 'second');
$self->_set_truncated;
$self->_set_valid_exp;
}
elsif ($date_string =~ /^([+-]) (\d+?) ([a-zA-Z]+)$/x) {
my ($prefix, $value, $unit) = ($1, $2, lc $3);
my %methods = (
'+' => '_add',
'-' => '_subtract',
);
my $method = $methods{$prefix};
if (none { $unit =~ /^${_}s?$/ } @{$self->{data}->__units('ordered')}) {
$self->_set_failure;
$self->_set_error("(invalid unit)");
return $self->_get_datetime_object;
}
$self->$method($unit => $value);
$self->_set_valid_exp;
}
elsif ($date_string =~ /^\d{14}$/) {
my %args;
@args{qw(year month day hour minute second)} = $date_string =~ /^(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})(\d{2})$/;
my $valid_date = $self->_check_date(map $args{$_}, qw(year month day));
my $valid_time = $self->_check_time(map $args{$_}, qw(hour minute second));
if (not $valid_date && $valid_time) {
my $type = !$valid_date ? 'date' : 'time';
$self->_set_failure;
$self->_set_error("(invalid $type)");
return $self->_get_datetime_object;
}
$self->_set(%args);
$self->{datetime}->truncate(to => 'second');
$self->_set_truncated;
$self->_set_valid_exp;
}
else {
@{$self->{tokens}} = split /\s+/, $date_string;
$self->{data}->__init('tokens')->($self);
$self->{count}{tokens} = @{$self->{tokens}};
$self->_process;
}
my $trace = $self->_trace_string;
if (defined $trace) {
@{$self->{traces}} = $trace;
}
return $self->_get_datetime_object;
}
sub _params_init
{
my $self = shift;
my $params = pop;
if (@_ > 1) {
validate(@_, { string => { type => SCALAR }});
my %opts = @_;
foreach my $opt (keys %opts) {
${$params->{$opt}} = $opts{$opt};
}
}
else {
validate_pos(@_, { type => SCALAR });
(${$params->{string}}) = @_;
}
trim($params->{string});
}
sub _parse_init
{
my $self = shift;
$self->_params_init(@_, { string => \$self->{date_string} });
my $set_datetime = sub
{
my ($method, $args) = @_;
if (exists $self->{Datetime} && $method eq 'now') {
$self->{datetime} = dclone($self->{Datetime});
}
else {
$self->{datetime} = DateTime::HiRes->$method(
time_zone => $self->{Time_zone},
%$args,
);
}
};
if ($self->{running_tests}) {
$self->{datetime} = $self->{datetime_test}->clone;
}
else {
$set_datetime->('now', {});
}
$self->_init_vars;
$self->_unset_failure;
$self->_unset_error;
$self->_unset_valid_exp;
$self->_unset_trace;
$self->_unset_truncated;
}
sub parse_datetime_duration
{
my $self = shift;
my $duration_string;
$self->_params_init(@_, { string => \$duration_string });
my $timespan_sep = $self->{data}->__timespan('literal');
my @date_strings = $duration_string =~ /\s+ $timespan_sep \s+/ix
? do { $self->{duration} = true;
split /\s+ $timespan_sep \s+/ix, $duration_string }
: do { $self->{duration} = false;
($duration_string) };
my $max = 2;
my $shrinked = false;
if (@date_strings > $max) {
my $offset = $max;
splice (@date_strings, $offset);
$shrinked = true;
}
$self->_rewrite_duration(\@date_strings);
$self->_pre_duration(\@date_strings);
@$self{qw(state truncated_duration)} = ({}, []);
my (@queue, @traces, @truncated);
foreach my $date_string (@date_strings) {
push @queue, $self->parse_datetime($date_string);
$self->_save_state(
valid_expression => $self->_get_valid_exp,
failure => $self->_get_failure,
error => $self->_get_error,
);
if (@{$self->{traces}}) {
push @traces, $self->{traces}[0];
}
if ($self->{running_tests}) {
push @truncated, $self->_get_truncated;
}
}
$self->_post_duration(\@queue, \@traces, \@truncated);
$self->_restore_state;
delete @$self{qw(duration insert state)};
@{$self->{traces}} = @traces;
@{$self->{truncated_duration}} = @truncated;
$self->{input_string} = $duration_string;
if ($shrinked) {
$self->_set_failure;
$self->_set_error("(limit of $max duration substrings exceeded)");
}
return @queue;
}
sub extract_datetime
{
my $self = shift;
my $extract_string;
$self->_params_init(@_, { string => \$extract_string });
$self->_unset_failure;
$self->_unset_error;
$self->_unset_valid_exp;
$self->{input_string} = $extract_string;
$self->{mode} = 'extract';
my @expressions = $self->_extract_expressions($extract_string);
$self->_set_valid_exp if @expressions;
return wantarray ? @expressions : $expressions[0];
}
sub success
{
my $self = shift;
return ($self->_get_valid_exp && !$self->_get_failure) ? true : false;
}
sub error
{
my $self = shift;
return '' if $self->success;
my $error = sub
{
return undef unless defined $self->{mode} && length $self->{mode};
my %errors = (
extract => "'$self->{input_string}' cannot be extracted from",
parse => "'$self->{input_string}' does not parse",
);
return $errors{$self->{mode}};
}->();
if (defined $error) {
$error .= ' ' . ($self->_get_error || '(perhaps you have some garbage?)');
}
else {
$error = 'neither extracting nor parsing method invoked';
}
return $error;
}
sub trace
{
my $self = shift;
return @{$self->{traces} || []};
}
sub _process
{
my $self = shift;
my %opts;
if (!exists $self->{lookup}) {
foreach my $keyword (keys %{$self->{data}->__grammar('')}) {
my $count = scalar @{$self->{data}->__grammar($keyword)->[0]};
push @{$self->{lookup}{$count}}, [ $keyword, false ];
if ($self->_expand_for($keyword)) {
push @{$self->{lookup}{$count + 1}}, [ $keyword, true ];
}
}
}
PARSE: foreach my $lookup (@{$self->{lookup}{$self->{count}{tokens}} || []}) {
my ($keyword, $expandable) = @$lookup;
my @grammar = @{$self->{data}->__grammar($keyword)};
my $types_entry = shift @grammar;
@grammar = $self->_expand($keyword, $types_entry, \@grammar) if $expandable;
foreach my $entry (@grammar) {
my ($types, $expression) = $expandable ? @$entry : ($types_entry, $entry);
my $valid_expression = true;
my $definition = $expression->[0];
my @positions = sort {$a <=> $b} keys %$definition;
my (%first_stack, %rest_stack);
foreach my $pos (@positions) {
if ($types->[$pos] eq 'SCALAR') {
if (defined $definition->{$pos}) {
if (${$self->_token($pos)} =~ /^$definition->{$pos}$/i) {
next;
}
else {
$valid_expression = false;
last;
}
}
}
elsif ($types->[$pos] eq 'REGEXP') {
if (my @captured = ${$self->_token($pos)} =~ $definition->{$pos}) {
$first_stack{$pos} = shift @captured;
$rest_stack{$pos} = [ @captured ];
next;
}
else {
$valid_expression = false;
last;
}
}
else {
die "grammar error at keyword \"$keyword\" within $self->{grammar_class}: ",
"unknown type $types->[$pos]\n";
}
}
if ($valid_expression && @{$expression->[2]}) {
my $i = 0;
foreach my $check (@{$expression->[2]}) {
my @pos = @{$expression->[1][$i++]};
my $error;
$valid_expression &= $check->(\%first_stack, \%rest_stack, \@pos, \$error);
unless ($valid_expression) {
$self->_set_error("($error)");
last;
}
}
}
if ($valid_expression) {
$self->_set_valid_exp;
my @truncate_to = @{$expression->[6]->{truncate_to} || []};
my $i = 0;
foreach my $positions (@{$expression->[3]}) {
my ($c, @values);
foreach my $pos (@$positions) {
my $index = ref $pos eq 'HASH' ? (keys %$pos)[0] : $pos;
$values[$c++] = ref $pos
? $index eq 'VALUE'
? $pos->{$index}
: $self->SUPER::_helper($pos->{$index}, $first_stack{$index})
: exists $first_stack{$index}
? $first_stack{$index}
: ${$self->_token($index)};
}
my $worker = "SUPER::$expression->[5]->[$i]";
$self->$worker(@values, $expression->[4]->[$i++]);
$self->_truncate(shift @truncate_to);
}
%opts = %{$expression->[6]};
$self->{keyword} = $keyword;
last PARSE;
}
}
}
$self->_post_process(%opts);
}
sub _truncate
{
my $self = shift;
my ($truncate_to) = @_;
return unless defined $truncate_to;
my @truncate_to = map { $_ =~ /_/ ? split /_/, $_ : $_ } $truncate_to;
my $i = 0;
my @units = @{$self->{data}->__units('ordered')};
my %indexes = map { $_ => $i++ } @units;
foreach my $unit (@truncate_to) {
my $index = $indexes{$unit} - 1;
if (defined $units[$index] && !exists $self->{modified}{$units[$index]}) {
$self->{datetime}->truncate(to => $unit);
$self->_set_truncated;
last;
}
}
}
sub _post_process
{
my $self = shift;
my %opts = @_;
delete $opts{truncate_to};
if (($self->{Prefer_future} || $self->{Demand_future})
&& (exists $opts{advance_future} && $opts{advance_future})
) {
$self->_advance_future;
}
}
sub _advance_future
{
my $self = shift;
my %advance = map { $_ => true } @_;
my %modified = map { $_ => true } keys %{$self->{modified}};
my $token_contains = sub
{
my ($identifier) = @_;
return any {
my $data = $_;
any {
my $token = $_;
$token =~ /^$data$/i;
} @{$self->{tokens}}
} @{$self->{data}->{$identifier}};
};
my $now = exists $self->{Datetime}
? dclone($self->{Datetime})
: DateTime::HiRes->now(time_zone => $self->{Time_zone});
my $day_of_week = sub { $_[0]->_Day_of_Week(map $_[0]->{datetime}->$_, qw(year month day)) };
my $skip_weekdays = false;
if ((all { /^(?:(?:nano)?second|minute|hour)$/ } keys %modified)
&& (exists $self->{modified}{hour} && $self->{modified}{hour} == 1)
&& (($self->{Prefer_future} && $self->{datetime} < $now)
|| ($self->{Demand_future} && $self->{datetime} <= $now))
) {
$self->{postprocess}{day} = 1;
}
elsif (sub {
return false unless @{$self->{tokens}} == 2;
my ($day, $weekday) = map $self->{data}->__RE($_), qw(day weekday);
if ($self->{tokens}->[0] =~ $day
&& $self->{tokens}->[1] =~ $weekday) {
$skip_weekdays = true;
return true;
}
return false;
}->()
&& (all { /^(?:day|month|year)$/ } keys %modified)
&& (($self->{Prefer_future} && $self->{datetime}->day < $now->day)
|| ($self->{Demand_future} && $self->{datetime}->day <= $now->day))
) {
$self->{postprocess}{week} = 4;
}
elsif (($token_contains->('weekdays_all') && !$skip_weekdays)
&& (exists $self->{modified}{day} && $self->{modified}{day} == 1)
&& (($self->{Prefer_future} && $day_of_week->($self) < $now->wday)
|| ($self->{Demand_future} && $day_of_week->($self) <= $now->wday))
) {
$self->{postprocess}{day} = 7;
}
elsif (($token_contains->('months_all') || $advance{md})
&& (all { /^(?:day|month)$/ } keys %modified)
&& (exists $self->{modified}{month} && $self->{modified}{month} == 1)
&& (exists $self->{modified}{day}
? $self->{modified}{day} == 1
? true : false
: true)
&& (($self->{Prefer_future} && $self->{datetime}->day_of_year < $now->day_of_year)
|| ($self->{Demand_future} && $self->{datetime}->day_of_year <= $now->day_of_year))
) {
$self->{postprocess}{year} = 1;
}
}
sub _token
{
my $self = shift;
my ($pos) = @_;
my $str = '';
my $token = $self->{tokens}->[0 + $pos];
return defined $token
? \$token
: \$str;
}
sub _register_trace { push @{$_[0]->{trace}}, (caller(1))[3] }
sub _unset_trace { @{$_[0]->{trace}} = () }
sub _get_error { $_[0]->{error} }
sub _set_error { $_[0]->{error} = $_[1] }
sub _unset_error { $_[0]->{error} = undef }
sub _get_failure { $_[0]->{failure} }
sub _set_failure { $_[0]->{failure} = true }
sub _unset_failure { $_[0]->{failure} = false }
sub _get_valid_exp { $_[0]->{valid_expression} }
sub _set_valid_exp { $_[0]->{valid_expression} = true }
sub _unset_valid_exp { $_[0]->{valid_expression} = false }
sub _get_truncated { $_[0]->{truncated} }
sub _set_truncated { $_[0]->{truncated} = true }
sub _unset_truncated { $_[0]->{truncated} = false }
sub _get_datetime_object
{
my $self = shift;
my $dt = DateTime->new(
time_zone => $self->{datetime}->time_zone,
year => $self->{datetime}->year,
month => $self->{datetime}->month,
day => $self->{datetime}->day_of_month,
hour => $self->{datetime}->hour,
minute => $self->{datetime}->minute,
second => $self->{datetime}->second,
nanosecond => $self->{datetime}->nanosecond,
);
foreach my $unit (keys %{$self->{postprocess}}) {
$dt->add("${unit}s" => $self->{postprocess}{$unit});
}
return $dt;
}
sub _set_datetime
{
my $self = shift;
my ($time, $tz) = @_;
$self->{datetime_test} = DateTime->new(
time_zone => $tz || 'floating',
%$time,
);
$self->{running_tests} = true;
}
1;