File Coverage

blib/lib/DateTime/Format/Natural.pm
Criterion Covered Total %
statement 389 409 95.1
branch 121 144 84.0
condition 73 106 68.8
subroutine 60 60 100.0
pod 7 7 100.0
total 650 726 89.5


line stmt bran cond sub pod time code
1             package DateTime::Format::Natural;
2              
3 26     26   2365987 use strict;
  26         215  
  26         801  
4 26     26   146 use warnings;
  26         62  
  26         878  
5 26         12231 use base qw(
6             DateTime::Format::Natural::Calc
7             DateTime::Format::Natural::Duration
8             DateTime::Format::Natural::Expand
9             DateTime::Format::Natural::Extract
10             DateTime::Format::Natural::Formatted
11             DateTime::Format::Natural::Helpers
12             DateTime::Format::Natural::Rewrite
13 26     26   180 );
  26         53  
14 26     26   196 use boolean qw(true false);
  26         57  
  26         149  
15              
16 26     26   1765 use Carp qw(croak);
  26         64  
  26         1246  
17 26     26   168 use DateTime ();
  26         52  
  26         394  
18 26     26   12055 use DateTime::HiRes ();
  26         42315  
  26         583  
19 26     26   188 use DateTime::TimeZone ();
  26         78  
  26         513  
20 26     26   151 use List::MoreUtils qw(all any none);
  26         81  
  26         247  
21 26     26   35245 use Params::Validate ':all';
  26         73371  
  26         4580  
22 26     26   253 use Scalar::Util qw(blessed);
  26         85  
  26         1366  
23 26     26   176 use Storable qw(dclone);
  26         56  
  26         1314  
24              
25 26     26   171 use DateTime::Format::Natural::Utils qw(trim);
  26         62  
  26         148518  
26              
27             our $VERSION = '1.18';
28              
29             validation_options(
30             on_fail => sub
31             {
32             my ($error) = @_;
33             chomp $error;
34             croak $error;
35             },
36             stack_skip => 2,
37             );
38              
39             sub new
40             {
41 10582     10582 1 142676 my $class = shift;
42              
43 10582   33     50324 my $self = bless {}, ref($class) || $class;
44              
45 10582         42363 $self->_init_check(@_);
46 10581         858936 $self->_init(@_);
47              
48 10581         27448 return $self;
49             }
50              
51             sub _init
52             {
53 10581     10581   21944 my $self = shift;
54 10581         28573 my %opts = @_;
55              
56 10581         30462 my %presets = (
57             lang => 'en',
58             format => 'd/m/y',
59             demand_future => false,
60             prefer_future => false,
61             time_zone => 'floating',
62             );
63 10581         87363 foreach my $opt (keys %presets) {
64 52905         124142 $self->{ucfirst $opt} = $presets{$opt};
65             }
66 10581         27737 foreach my $opt (keys %opts) {
67 7004 50       17028 if (defined $opts{$opt}) {
68 7004         15565 $self->{ucfirst $opt} = $opts{$opt};
69             }
70             }
71 10581   100     50259 $self->{Daytime} = $opts{daytime} || {};
72              
73 10581         38117 my $mod = join '::', (__PACKAGE__, 'Lang', uc $self->{Lang});
74 10581 50       794665 eval "require $mod" or die $@;
75              
76 10581         62531 $self->{data} = $mod->__new();
77 10581         29613 $self->{grammar_class} = $mod;
78              
79 10581         43111 $self->{mode} = '';
80             }
81              
82             sub _init_check
83             {
84 10582     10582   19470 my $self = shift;
85              
86             validate(@_, {
87             demand_future => {
88             # SCALARREF due to boolean.pm's implementation
89             type => BOOLEAN | SCALARREF,
90             optional => true,
91             callbacks => {
92             'mutually exclusive' => sub
93             {
94 1073 100   1073   69574 return true unless exists $_[1]->{prefer_future};
95 1         9 die "prefer_future provided\n";
96             },
97             },
98             },
99             lang => {
100             type => SCALAR,
101             optional => true,
102             regex => qr!^(?:en)$!i,
103             },
104             format => {
105             type => SCALAR,
106             optional => true,
107             regex => qr!^(?:
108             (?: (?: [dmy]{1,4}[-./] ){2}[dmy]{1,4} )
109             |
110             (?: [dm]{1,2}/[dm]{1,2} )
111             )$!ix,
112             },
113             prefer_future => {
114             # SCALARREF due to boolean.pm's implementation
115             type => BOOLEAN | SCALARREF,
116             optional => true,
117             callbacks => {
118             'mutually exclusive' => sub
119             {
120 1090 50   1090   66537 return true unless exists $_[1]->{demand_future};
121 0         0 die "demand_future provided\n";
122             },
123             },
124             },
125             time_zone => {
126             type => SCALAR | OBJECT,
127             optional => true,
128             callbacks => {
129             'valid timezone' => sub
130             {
131 1562     1562   84052 my $val = shift;
132 1562 100       5484 if (blessed($val)) {
133 1         17 return $val->isa('DateTime::TimeZone');
134             }
135             else {
136 1561         2528 eval { DateTime::TimeZone->new(name => $val) };
  1561         6062  
137 1561         124601 return !$@;
138             }
139             }
140             },
141             },
142             daytime => {
143             type => HASHREF,
144             optional => true,
145             callbacks => {
146             'valid daytime' => sub
147             {
148 39     39   2037 my $href = shift;
149 39         89 my %daytimes = map { $_ => true } qw(morning afternoon evening);
  117         363  
150 39 50       502 if (any { !$daytimes{$_} } keys %$href) {
  58 50       383  
    50          
    50          
151 0         0 die "spelling of daytime\n";
152             }
153 58         342 elsif (any { !defined $href->{$_} } keys %$href) {
154 0         0 die "undefined hour\n";
155             }
156 58         285 elsif (any { $href->{$_} !~ /^\d{1,2}$/ } keys %$href) {
157 0         0 die "not a valid number\n";
158             }
159 58 50       203 elsif (any { $href->{$_} < 0 || $href->{$_} > 23 } keys %$href) {
160 0         0 die "hour out of range\n";
161             }
162             else {
163 39         105 return true;
164             }
165             }
166             },
167             },
168             datetime => {
169             type => OBJECT,
170             optional => true,
171             callbacks => {
172             'valid object' => sub
173             {
174 26     26   1110 my $obj = shift;
175 26 50       412 blessed($obj) && $obj->isa('DateTime');
176             }
177             },
178             },
179 10582         38821 });
180             }
181              
182             sub _init_vars
183             {
184 11703     11703   22091 my $self = shift;
185              
186 11703         34986 delete @$self{qw(keyword modified postprocess)};
187             }
188              
189             sub parse_datetime
190             {
191 11703     11703 1 61477 my $self = shift;
192              
193 11703         35196 $self->_parse_init(@_);
194              
195 11703         88990 $self->{input_string} = $self->{date_string};
196              
197 11703         22442 $self->{mode} = 'parse';
198              
199 11703         20029 my $date_string = $self->{date_string};
200              
201 11703         46464 $self->_rewrite(\$date_string);
202              
203 11703         72529 my ($formatted) = $date_string =~ $self->{data}->__regexes('format');
204 11703         49422 my %count = $self->_count_separators($formatted);
205              
206 11703         30511 $self->{tokens} = [];
207 11703         26930 $self->{traces} = [];
208              
209 11703 100       36314 if ($self->_check_formatted('ymd', \%count)) {
    100          
    100          
    100          
    100          
210 271         1083 my $dt = $self->_parse_formatted_ymd($date_string, \%count);
211 271 100       1066 return $dt if blessed($dt);
212             }
213             elsif ($self->_check_formatted('md', \%count)) {
214 193         709 my $dt = $self->_parse_formatted_md($date_string);
215 193 100       749 return $dt if blessed($dt);
216              
217 192 100 100     543 if ($self->{Prefer_future} || $self->{Demand_future}) {
218 36         497 $self->_advance_future('md');
219             }
220             }
221             elsif ($date_string =~ /^(\d{4}(?:-\d{2}){0,2})T(\d{2}(?::\d{2}){0,2})$/) {
222 9         37 my ($date, $time) = ($1, $2);
223              
224 9         16 my %args;
225              
226 9         37 @args{qw(year month day)} = split /-/, $date;
227 9   100     51 $args{$_} ||= 01 foreach qw(month day);
228              
229 9         31 @args{qw(hour minute second)} = split /:/, $time;
230 9   100     42 $args{$_} ||= 00 foreach qw(minute second);
231              
232 9         57 my $valid_date = $self->_check_date(map $args{$_}, qw(year month day));
233 9         46 my $valid_time = $self->_check_time(map $args{$_}, qw(hour minute second));
234              
235 9 50 33     41 if (not $valid_date && $valid_time) {
236 0 0       0 my $type = !$valid_date ? 'date' : 'time';
237 0         0 $self->_set_failure;
238 0         0 $self->_set_error("(invalid $type)");
239 0         0 return $self->_get_datetime_object;
240             }
241              
242 9         46 $self->_set(%args);
243              
244 9         36 $self->{datetime}->truncate(to => 'second');
245 9         2299 $self->_set_truncated;
246 9         36 $self->_set_valid_exp;
247             }
248             elsif ($date_string =~ /^([+-]) (\d+?) ([a-zA-Z]+)$/x) {
249 14         85 my ($prefix, $value, $unit) = ($1, $2, lc $3);
250              
251 14         51 my %methods = (
252             '+' => '_add',
253             '-' => '_subtract',
254             );
255 14         28 my $method = $methods{$prefix};
256              
257 14 100   64   49 if (none { $unit =~ /^${_}s?$/ } @{$self->{data}->__units('ordered')}) {
  64         707  
  14         98  
258 2         8 $self->_set_failure;
259 2         14 $self->_set_error("(invalid unit)");
260 2         6 return $self->_get_datetime_object;
261             }
262 12         96 $self->$method($unit => $value);
263              
264 12         38 $self->_set_valid_exp;
265             }
266             elsif ($date_string =~ /^\d{14}$/) {
267 6         13 my %args;
268 6         42 @args{qw(year month day hour minute second)} = $date_string =~ /^(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})(\d{2})$/;
269              
270 6         49 my $valid_date = $self->_check_date(map $args{$_}, qw(year month day));
271 6         42 my $valid_time = $self->_check_time(map $args{$_}, qw(hour minute second));
272              
273 6 50 33     45 if (not $valid_date && $valid_time) {
274 0 0       0 my $type = !$valid_date ? 'date' : 'time';
275 0         0 $self->_set_failure;
276 0         0 $self->_set_error("(invalid $type)");
277 0         0 return $self->_get_datetime_object;
278             }
279              
280 6         45 $self->_set(%args);
281              
282 6         43 $self->{datetime}->truncate(to => 'second');
283 6         1557 $self->_set_truncated;
284 6         31 $self->_set_valid_exp;
285             }
286             else {
287 11210         21459 @{$self->{tokens}} = split /\s+/, $date_string;
  11210         58684  
288 11210         64634 $self->{data}->__init('tokens')->($self);
289 11210         19801 $self->{count}{tokens} = @{$self->{tokens}};
  11210         34799  
290              
291 11210         30462 $self->_process;
292             }
293              
294 11699         227413 my $trace = $self->_trace_string;
295 11699 100       38501 if (defined $trace) {
296 11339         19714 @{$self->{traces}} = $trace;
  11339         33643  
297             }
298              
299 11699         33319 return $self->_get_datetime_object;
300             }
301              
302             sub _params_init
303             {
304 13170     13170   21401 my $self = shift;
305 13170         21415 my $params = pop;
306              
307 13170 50       34756 if (@_ > 1) {
308 0         0 validate(@_, { string => { type => SCALAR }});
309 0         0 my %opts = @_;
310 0         0 foreach my $opt (keys %opts) {
311 0         0 ${$params->{$opt}} = $opts{$opt};
  0         0  
312             }
313             }
314             else {
315 13170         174200 validate_pos(@_, { type => SCALAR });
316 13170         44978 (${$params->{string}}) = @_;
  13170         35303  
317             }
318              
319 13170         47446 trim($params->{string});
320             }
321              
322             sub _parse_init
323             {
324 11703     11703   18714 my $self = shift;
325              
326 11703         49855 $self->_params_init(@_, { string => \$self->{date_string} });
327              
328             my $set_datetime = sub
329             {
330 2907     2907   7076 my ($method, $args) = @_;
331              
332 2907 100 66     9637 if (exists $self->{Datetime} && $method eq 'now') {
333 24         284 $self->{datetime} = dclone($self->{Datetime});
334             }
335             else {
336             $self->{datetime} = DateTime::HiRes->$method(
337             time_zone => $self->{Time_zone},
338 2883         14812 %$args,
339             );
340             }
341 11703         58613 };
342              
343 11703 100       39795 if ($self->{running_tests}) {
344 8796         80923 $self->{datetime} = $self->{datetime_test}->clone;
345             }
346             else {
347 2907         7098 $set_datetime->('now', {});
348             }
349              
350 11703         1652555 $self->_init_vars;
351              
352 11703         33979 $self->_unset_failure;
353 11703         55324 $self->_unset_error;
354 11703         30077 $self->_unset_valid_exp;
355 11703         59171 $self->_unset_trace;
356 11703         26326 $self->_unset_truncated;
357             }
358              
359             sub parse_datetime_duration
360             {
361 1258     1258 1 251915 my $self = shift;
362              
363 1258         2319 my $duration_string;
364 1258         5769 $self->_params_init(@_, { string => \$duration_string });
365 1258         8972 my $timespan_sep = $self->{data}->__timespan('literal');
366              
367             my @date_strings = $duration_string =~ /\s+ $timespan_sep \s+/ix
368 1039         3304 ? do { $self->{duration} = true;
369 1039         8412 split /\s+ $timespan_sep \s+/ix, $duration_string }
370 1258 100       9310 : do { $self->{duration} = false;
  219         785  
371 219         1183 ($duration_string) };
372              
373 1258         2596 my $max = 2;
374              
375 1258         3151 my $shrinked = false;
376 1258 100       5329 if (@date_strings > $max) {
377 1         3 my $offset = $max;
378 1         4 splice (@date_strings, $offset);
379 1         3 $shrinked = true;
380             }
381              
382 1258         5844 $self->_rewrite_duration(\@date_strings);
383              
384 1258         7021 $self->_pre_duration(\@date_strings);
385 1258         17841 @$self{qw(state truncated_duration)} = ({}, []);
386              
387 1258         3305 my (@queue, @traces, @truncated);
388 1258         2818 foreach my $date_string (@date_strings) {
389 2297         6284 push @queue, $self->parse_datetime($date_string);
390 2297         5843 $self->_save_state(
391             valid_expression => $self->_get_valid_exp,
392             failure => $self->_get_failure,
393             error => $self->_get_error,
394             );
395 2297 100       18955 if (@{$self->{traces}}) {
  2297         5956  
396 2292         5385 push @traces, $self->{traces}[0];
397             }
398 2297 100       6423 if ($self->{running_tests}) {
399 1932         13549 push @truncated, $self->_get_truncated;
400             }
401             }
402              
403 1258         6483 $self->_post_duration(\@queue, \@traces, \@truncated);
404 1258         7049 $self->_restore_state;
405              
406 1258         5184 delete @$self{qw(duration insert state)};
407              
408 1258         2334 @{$self->{traces}} = @traces;
  1258         3292  
409 1258         2283 @{$self->{truncated_duration}} = @truncated;
  1258         2730  
410 1258         2709 $self->{input_string} = $duration_string;
411              
412 1258 100       3093 if ($shrinked) {
413 1         17 $self->_set_failure;
414 1         10 $self->_set_error("(limit of $max duration substrings exceeded)");
415             }
416              
417 1258         14064 return @queue;
418             }
419              
420             sub extract_datetime
421             {
422 209     209 1 8401 my $self = shift;
423              
424 209         467 my $extract_string;
425 209         1007 $self->_params_init(@_, { string => \$extract_string });
426              
427 209         1182 $self->_unset_failure;
428 209         1076 $self->_unset_error;
429 209         664 $self->_unset_valid_exp;
430              
431 209         1105 $self->{input_string} = $extract_string;
432              
433 209         536 $self->{mode} = 'extract';
434              
435 209         1084 my @expressions = $self->_extract_expressions($extract_string);
436              
437 209 100       2436 $self->_set_valid_exp if @expressions;
438              
439 209 100       1988 return wantarray ? @expressions : $expressions[0];
440             }
441              
442             sub success
443             {
444 10602     10602 1 66362 my $self = shift;
445              
446 10602 100 100     24538 return ($self->_get_valid_exp && !$self->_get_failure) ? true : false;
447             }
448              
449             sub error
450             {
451 6     6 1 54 my $self = shift;
452              
453 6 100       16 return '' if $self->success;
454              
455             my $error = sub
456             {
457 5 100 66 5   33 return undef unless defined $self->{mode} && length $self->{mode};
458 4         29 my %errors = (
459             extract => "'$self->{input_string}' cannot be extracted from",
460             parse => "'$self->{input_string}' does not parse",
461             );
462 4         13 return $errors{$self->{mode}};
463 5         122 }->();
464              
465 5 100       34 if (defined $error) {
466 4   100     24 $error .= ' ' . ($self->_get_error || '(perhaps you have some garbage?)');
467             }
468             else {
469 1         3 $error = 'neither extracting nor parsing method invoked';
470             }
471              
472 5         40 return $error;
473             }
474              
475             sub trace
476             {
477 7     7 1 51 my $self = shift;
478              
479 7 100       12 return @{$self->{traces} || []};
  7         43  
480             }
481              
482             sub _process
483             {
484 11531     11531   19983 my $self = shift;
485              
486 11531         17835 my %opts;
487              
488 11531 100       29283 if (!exists $self->{lookup}) {
489 10414         15801 foreach my $keyword (keys %{$self->{data}->__grammar('')}) {
  10414         48644  
490 697738         5412088 my $count = scalar @{$self->{data}->__grammar($keyword)->[0]};
  697738         2577118  
491 697738         1103281 push @{$self->{lookup}{$count}}, [ $keyword, false ];
  697738         1720674  
492 697738 100       3013971 if ($self->_expand_for($keyword)) {
493 197866         1762125 push @{$self->{lookup}{$count + 1}}, [ $keyword, true ];
  197866         504798  
494             }
495             }
496             }
497              
498 11531 50       129672 PARSE: foreach my $lookup (@{$self->{lookup}{$self->{count}{tokens}} || []}) {
  11531         49887  
499 100179         1222963 my ($keyword, $expandable) = @$lookup;
500              
501 100179         144969 my @grammar = @{$self->{data}->__grammar($keyword)};
  100179         476344  
502 100179         199556 my $types_entry = shift @grammar;
503              
504 100179 100       233545 @grammar = $self->_expand($keyword, $types_entry, \@grammar) if $expandable;
505              
506 100179         657629 foreach my $entry (@grammar) {
507 559353 100       3692967 my ($types, $expression) = $expandable ? @$entry : ($types_entry, $entry);
508 559353         3924543 my $valid_expression = true;
509 559353         1662323 my $definition = $expression->[0];
510 559353         1612944 my @positions = sort {$a <=> $b} keys %$definition;
  1690493         3125825  
511 559353         945254 my (%first_stack, %rest_stack);
512 559353         901152 foreach my $pos (@positions) {
513 667702 100       1480241 if ($types->[$pos] eq 'SCALAR') {
    50          
514 70348 50       151021 if (defined $definition->{$pos}) {
515 70348 100       95118 if (${$self->_token($pos)} =~ /^$definition->{$pos}$/i) {
  70348         132145  
516 6387         16622 next;
517             }
518             else {
519 63961         152726 $valid_expression = false;
520 63961         212970 last;
521             }
522             }
523             }
524             elsif ($types->[$pos] eq 'REGEXP') {
525 597354 100       814184 if (my @captured = ${$self->_token($pos)} =~ $definition->{$pos}) {
  597354         1076874  
526 113499         281988 $first_stack{$pos} = shift @captured;
527 113499         209425 $rest_stack{$pos} = [ @captured ];
528 113499         250870 next;
529             }
530             else {
531 483855         1067084 $valid_expression = false;
532 483855         1475077 last;
533             }
534             }
535             else {
536 0         0 die "grammar error at keyword \"$keyword\" within $self->{grammar_class}: ",
537             "unknown type $types->[$pos]\n";
538             }
539             }
540 559353 100 100     1260741 if ($valid_expression && @{$expression->[2]}) {
  11537         110176  
541 8573         16046 my $i = 0;
542 8573         14620 foreach my $check (@{$expression->[2]}) {
  8573         20426  
543 10839         16880 my @pos = @{$expression->[1][$i++]};
  10839         30410  
544 10839         18911 my $error;
545 10839         38365 $valid_expression &= $check->(\%first_stack, \%rest_stack, \@pos, \$error);
546 10839 100       65009 unless ($valid_expression) {
547 366         1792 $self->_set_error("($error)");
548 366         849 last;
549             }
550             }
551             }
552 559353 100       4013217 if ($valid_expression) {
553 11171         48496 $self->_set_valid_exp;
554 11171 100       39642 my @truncate_to = @{$expression->[6]->{truncate_to} || []};
  11171         42540  
555 11171         21371 my $i = 0;
556 11171         17438 foreach my $positions (@{$expression->[3]}) {
  11171         24674  
557 19578         33436 my ($c, @values);
558 19578         38484 foreach my $pos (@$positions) {
559 24633 100       81656 my $index = ref $pos eq 'HASH' ? (keys %$pos)[0] : $pos;
560             $values[$c++] = ref $pos
561             ? $index eq 'VALUE'
562             ? $pos->{$index}
563             : $self->SUPER::_helper($pos->{$index}, $first_stack{$index})
564             : exists $first_stack{$index}
565             ? $first_stack{$index}
566 24633 100       118367 : ${$self->_token($index)};
  0 50       0  
    100          
567             }
568 19578         51179 my $worker = "SUPER::$expression->[5]->[$i]";
569 19578         94659 $self->$worker(@values, $expression->[4]->[$i++]);
570 19578         86205 $self->_truncate(shift @truncate_to);
571             }
572 11171         22072 %opts = %{$expression->[6]};
  11171         37019  
573 11171         27759 $self->{keyword} = $keyword;
574 11171         99521 last PARSE;
575             }
576             }
577             }
578              
579 11531         41469 $self->_post_process(%opts);
580             }
581              
582             sub _truncate
583             {
584 19578     19578   34534 my $self = shift;
585 19578         39721 my ($truncate_to) = @_;
586              
587 19578 100       61720 return unless defined $truncate_to;
588              
589 11813 100       24119 my @truncate_to = map { $_ =~ /_/ ? split /_/, $_ : $_ } $truncate_to;
  11813         70727  
590 11813         24269 my $i = 0;
591 11813         19123 my @units = @{$self->{data}->__units('ordered')};
  11813         75937  
592 11813         28686 my %indexes = map { $_ => $i++ } @units;
  94504         179770  
593 11813         30878 foreach my $unit (@truncate_to) {
594 20487         39018 my $index = $indexes{$unit} - 1;
595 20487 100 66     87726 if (defined $units[$index] && !exists $self->{modified}{$units[$index]}) {
596 11759         46170 $self->{datetime}->truncate(to => $unit);
597 11759         3421144 $self->_set_truncated;
598 11759         87029 last;
599             }
600             }
601             }
602              
603             sub _post_process
604             {
605 11531     11531   20079 my $self = shift;
606 11531         25806 my %opts = @_;
607              
608 11531         23246 delete $opts{truncate_to};
609              
610 11531 50 100     39954 if (($self->{Prefer_future} || $self->{Demand_future})
      66        
      66        
611             && (exists $opts{advance_future} && $opts{advance_future})
612             ) {
613 2070         41369 $self->_advance_future;
614             }
615             }
616              
617             sub _advance_future
618             {
619 2106     2106   3852 my $self = shift;
620 2106         4580 my %advance = map { $_ => true } @_;
  36         80  
621              
622 2106         3462 my %modified = map { $_ => true } keys %{$self->{modified}};
  6156         19240  
  2106         6969  
623             my $token_contains = sub
624             {
625 2520     2520   40010 my ($identifier) = @_;
626             return any {
627 27066         66076 my $data = $_;
628             any {
629 43158         69852 my $token = $_;
630 43158         233575 $token =~ /^$data$/i;
631 27066         65879 } @{$self->{tokens}}
  27066         60178  
632 2520         9770 } @{$self->{data}->{$identifier}};
  2520         10713  
633 2106         16534 };
634              
635             my $now = exists $self->{Datetime}
636             ? dclone($self->{Datetime})
637 2106 100       10396 : DateTime::HiRes->now(time_zone => $self->{Time_zone});
638              
639 2106     1530   1043385 my $day_of_week = sub { $_[0]->_Day_of_Week(map $_[0]->{datetime}->$_, qw(year month day)) };
  1530         51451  
640              
641 2106         6908 my $skip_weekdays = false;
642              
643 2106 50 33 4366   16072 if ((all { /^(?:(?:nano)?second|minute|hour)$/ } keys %modified)
  4366 100 66     25581  
    100 100        
    100 66        
    100 66        
    100 66        
      66        
      100        
      33        
      66        
      66        
      33        
      100        
      66        
      33        
      66        
      33        
      66        
      33        
644             && (exists $self->{modified}{hour} && $self->{modified}{hour} == 1)
645             && (($self->{Prefer_future} && $self->{datetime} < $now)
646             || ($self->{Demand_future} && $self->{datetime} <= $now))
647             ) {
648 234         26185 $self->{postprocess}{day} = 1;
649             }
650             elsif (sub {
651 1872 100   1872   26292 return false unless @{$self->{tokens}} == 2;
  1872         6788  
652 1398         10325 my ($day, $weekday) = map $self->{data}->__RE($_), qw(day weekday);
653 1398 100 100     10081 if ($self->{tokens}->[0] =~ $day
654             && $self->{tokens}->[1] =~ $weekday) {
655 36         156 $skip_weekdays = true;
656 36         141 return true;
657             }
658 1362         3711 return false;
659             }->()
660 108     108   946 && (all { /^(?:day|month|year)$/ } keys %modified)
661             && (($self->{Prefer_future} && $self->{datetime}->day < $now->day)
662             || ($self->{Demand_future} && $self->{datetime}->day <= $now->day))
663             ) {
664 18         648 $self->{postprocess}{week} = 4;
665             }
666             elsif (($token_contains->('weekdays_all') && !$skip_weekdays)
667             && (exists $self->{modified}{day} && $self->{modified}{day} == 1)
668             && (($self->{Prefer_future} && $day_of_week->($self) < $now->wday)
669             || ($self->{Demand_future} && $day_of_week->($self) <= $now->wday))
670             ) {
671 1188         18598 $self->{postprocess}{day} = 7;
672             }
673             elsif (($token_contains->('months_all') || $advance{md})
674 156     156   1943 && (all { /^(?:day|month)$/ } keys %modified)
675             && (exists $self->{modified}{month} && $self->{modified}{month} == 1)
676             && (exists $self->{modified}{day}
677             ? $self->{modified}{day} == 1
678             ? true : false
679             : true)
680             && (($self->{Prefer_future} && $self->{datetime}->day_of_year < $now->day_of_year)
681             || ($self->{Demand_future} && $self->{datetime}->day_of_year <= $now->day_of_year))
682             ) {
683 72         3154 $self->{postprocess}{year} = 1;
684             }
685             }
686              
687             sub _token
688             {
689 667702     667702   962023 my $self = shift;
690 667702         1080627 my ($pos) = @_;
691              
692 667702         941405 my $str = '';
693 667702         1310994 my $token = $self->{tokens}->[0 + $pos];
694              
695 667702 50       3545706 return defined $token
696             ? \$token
697             : \$str;
698             }
699              
700 19578     19578   30451 sub _register_trace { push @{$_[0]->{trace}}, (caller(1))[3] }
  19578         159329  
701 11703     11703   18694 sub _unset_trace { @{$_[0]->{trace}} = () }
  11703         31756  
702              
703 2652     2652   17909 sub _get_error { $_[0]->{error} }
704 372     372   1018 sub _set_error { $_[0]->{error} = $_[1] }
705 11914     11914   24299 sub _unset_error { $_[0]->{error} = undef }
706              
707 12538     12538   108447 sub _get_failure { $_[0]->{failure} }
708 6     6   32 sub _set_failure { $_[0]->{failure} = true }
709 11914     11914   29365 sub _unset_failure { $_[0]->{failure} = false }
710              
711 12899     12899   45741 sub _get_valid_exp { $_[0]->{valid_expression} }
712 11868     11868   27345 sub _set_valid_exp { $_[0]->{valid_expression} = true }
713 12236     12236   24377 sub _unset_valid_exp { $_[0]->{valid_expression} = false }
714              
715 10779     10779   186792 sub _get_truncated { $_[0]->{truncated} }
716 12236     12236   36810 sub _set_truncated { $_[0]->{truncated} = true }
717 12024     12024   25120 sub _unset_truncated { $_[0]->{truncated} = false }
718              
719             sub _get_datetime_object
720             {
721 11703     11703   19774 my $self = shift;
722              
723             my $dt = DateTime->new(
724             time_zone => $self->{datetime}->time_zone,
725             year => $self->{datetime}->year,
726             month => $self->{datetime}->month,
727             day => $self->{datetime}->day_of_month,
728             hour => $self->{datetime}->hour,
729             minute => $self->{datetime}->minute,
730             second => $self->{datetime}->second,
731             nanosecond => $self->{datetime}->nanosecond,
732 11703         38045 );
733              
734 11703         3694180 foreach my $unit (keys %{$self->{postprocess}}) {
  11703         45633  
735 1512         6983 $dt->add("${unit}s" => $self->{postprocess}{$unit});
736             }
737              
738 11703         1556361 return $dt;
739             }
740              
741             # solely for testing purpose
742             sub _set_datetime
743             {
744 7806     7806   34156 my $self = shift;
745 7806         18234 my ($time, $tz) = @_;
746              
747 7806   100     55200 $self->{datetime_test} = DateTime->new(
748             time_zone => $tz || 'floating',
749             %$time,
750             );
751 7806         2934778 $self->{running_tests} = true;
752             }
753              
754             1;
755             __END__
756              
757             =encoding ISO8859-1
758              
759             =head1 NAME
760              
761             DateTime::Format::Natural - Parse informal natural language date/time strings
762              
763             =head1 SYNOPSIS
764              
765             use DateTime::Format::Natural;
766              
767             $parser = DateTime::Format::Natural->new;
768              
769             $dt = $parser->parse_datetime($date_string);
770             @dt = $parser->parse_datetime_duration($date_string);
771              
772             $date_string = $parser->extract_datetime($extract_string);
773             @date_strings = $parser->extract_datetime($extract_string);
774              
775             if ($parser->success) {
776             # operate on $dt/@dt, for example:
777             print $dt->strftime('%d.%m.%Y %H:%M:%S'), "\n";
778             } else {
779             warn $parser->error;
780             }
781              
782             @traces = $parser->trace;
783              
784             # examples
785              
786             12:14 PM
787             next tuesday at 2am
788             tomorrow morning
789             4pm yesterday
790             10 weeks ago
791              
792             1st tuesday last november
793             2nd friday in august
794             final thursday in april
795              
796             for 3 hours
797             monday to friday
798             1 April 10 am to 1 May 8am
799              
800             jan 24, 2011 12:00
801              
802             =head1 DESCRIPTION
803              
804             C<DateTime::Format::Natural> parses informal natural language date/time strings.
805             In addition, parsable date/time substrings may be extracted from ordinary strings.
806              
807             =head1 CONSTRUCTOR
808              
809             =head2 new
810              
811             Creates a new C<DateTime::Format::Natural> object. Arguments to C<new()> are options and
812             not necessarily required.
813              
814             $parser = DateTime::Format::Natural->new(
815             datetime => DateTime->new(...),
816             lang => 'en',
817             format => 'mm/dd/yy',
818             prefer_future => [0|1],
819             demand_future => [0|1],
820             time_zone => 'floating',
821             daytime => { morning => 06,
822             afternoon => 13,
823             evening => 20,
824             },
825             );
826              
827             =over 4
828              
829             =item * C<datetime>
830              
831             Overrides the present now with a L<DateTime> object provided.
832              
833             =item * C<lang>
834              
835             Contains the language selected, currently limited to C<en> (english).
836             Defaults to 'C<en>'.
837              
838             =item * C<format>
839              
840             Specifies the format of numeric dates.
841              
842             The format is used to influence how numeric dates are parsed. Given two
843             numbers separated by a slash, the month/day order expected comes from
844             this option. If there is a third number, this option describes where
845             to expect the year. When this format can't be used to interpret the
846             date, some unambiguous dates may be parsed, but there is no form
847             guarantee.
848              
849             Current supported "month/day" formats: C<dd/mm>, C<mm/dd>.
850              
851             Current supported "year/month/day" formats (with slashes): C<dd/mm/yy>,
852             C<dd/mm/yyyy>, C<mm/dd/yyyy>, C<yyyy/mm/dd>.
853              
854             Note that all of the above formats with three units do also parse
855             with dots or dashes as format separators.
856              
857             Furthermore, formats can be abbreviated as long as they remain
858             unambiguous.
859              
860             Defaults to 'C<d/m/y>'.
861              
862             =item * C<prefer_future>
863              
864             Prefers future time and dates. Accepts a boolean, defaults to false.
865              
866             =item * C<demand_future>
867              
868             Demands future time and dates. Similar to C<prefer_future>, but stronger.
869             Accepts a boolean, defaults to false.
870              
871             =item * C<time_zone>
872              
873             The time zone to use when parsing and for output. Accepts any time zone
874             recognized by L<DateTime>. Defaults to 'floating'.
875              
876             =item * C<daytime>
877              
878             A hash reference consisting of customized daytime hours,
879             which may be selectively changed.
880              
881             =back
882              
883             =head1 METHODS
884              
885             =head2 parse_datetime
886              
887             Returns a L<DateTime> object constructed from a natural language date/time string.
888              
889             $dt = $parser->parse_datetime($date_string);
890             $dt = $parser->parse_datetime(string => $date_string);
891              
892             =over 4
893              
894             =item * C<string>
895              
896             The date string.
897              
898             =back
899              
900             =head2 parse_datetime_duration
901              
902             Returns one or two L<DateTime> objects constructed from a natural language
903             date/time string which may contain timespans/durations. I<Same> interface
904             and options as C<parse_datetime()>, but should be explicitly called in
905             list context.
906              
907             @dt = $parser->parse_datetime_duration($date_string);
908             @dt = $parser->parse_datetime_duration(string => $date_string);
909              
910             =head2 extract_datetime
911              
912             Returns parsable date/time substrings (also known as expressions) extracted
913             from the string provided; in scalar context only the first parsable substring
914             is returned, whereas in list context all parsable substrings are returned.
915             Each extracted substring can then be passed to the C<parse_datetime()>/
916             C<parse_datetime_duration()> methods.
917              
918             $date_string = $parser->extract_datetime($extract_string);
919             @date_strings = $parser->extract_datetime($extract_string);
920             # or
921             $date_string = $parser->extract_datetime(string => $extract_string);
922             @date_strings = $parser->extract_datetime(string => $extract_string);
923              
924             =head2 success
925              
926             Returns a boolean indicating success or failure for parsing the date/time
927             string given.
928              
929             =head2 error
930              
931             Returns the error message if the parsing did not succeed.
932              
933             =head2 trace
934              
935             Returns one or two strings with the grammar keyword for the valid
936             expression parsed, traces of methods which were called within the Calc
937             class and a summary how often certain units have been modified. More than
938             one string is commonly returned for durations. Useful as a debugging aid.
939              
940             =head1 GRAMMAR
941              
942             The grammar handling has been rewritten to be easily extendable and hence
943             everybody is encouraged to propose sensible new additions and/or changes.
944              
945             See the class L<DateTime::Format::Natural::Lang::EN> if you're intending
946             to hack a bit on the grammar guts.
947              
948             =head1 EXAMPLES
949              
950             See the class L<DateTime::Format::Natural::Lang::EN> for an overview of
951             currently valid input.
952              
953             =head1 BUGS & CAVEATS
954              
955             C<parse_datetime()>/C<parse_datetime_duration()> always return one or two
956             DateTime objects regardless whether the parse was successful or not. In
957             case no valid expression was found or a failure occurred, an unaltered
958             DateTime object with its initial values (most often the "current" now) is
959             likely to be returned. It is therefore recommended to use C<success()> to
960             assert that the parse did succeed (at least, for common uses), otherwise
961             the absence of a parse failure cannot be guaranteed.
962              
963             C<parse_datetime()> is not capable of handling durations.
964              
965             =head1 CREDITS
966              
967             Thanks to Tatsuhiko Miyagawa for the initial inspiration. See Miyagawa's journal
968             entry L<http://use.perl.org/~miyagawa/journal/31378> for more information.
969              
970             Furthermore, thanks to (in order of appearance) who have contributed
971             valuable suggestions and patches:
972              
973             Clayton L. Scott
974             Dave Rolsky
975             CPAN Author 'SEKIMURA'
976             mike (pulsation)
977             Mark Stosberg
978             Tuomas Jormola
979             Cory Watson
980             Urs Stotz
981             Shawn M. Moore
982             Andreas J. König
983             Chia-liang Kao
984             Jonny Schulz
985             Jesse Vincent
986             Jason May
987             Pat Kale
988             Ankur Gupta
989             Alex Bowley
990             Elliot Shank
991             Anirvan Chatterjee
992             Michael Reddick
993             Christian Brink
994             Giovanni Pensa
995             Andrew Sterling Hanenkamp
996             Eric Wilhelm
997             Kevin Field
998             Wes Morgan
999             Vladimir Marek
1000             Rod Taylor
1001             Tim Esselens
1002             Colm Dougan
1003             Chifung Fan
1004             Xiao Yafeng
1005             Roman Filippov
1006             David Steinbrunner
1007             Debian Perl Group
1008             Tim Bunce
1009             Ricardo Signes
1010             Felix Ostmann
1011             Jörn Clausen
1012             Jim Avera
1013             Olaf Alders
1014             Karen Etheridge
1015              
1016             =head1 SEE ALSO
1017              
1018             L<dateparse>, L<DateTime>, L<Date::Calc>, L<http://datetime.perl.org>
1019              
1020             =head1 AUTHOR
1021              
1022             Steven Schubiger <schubiger@cpan.org>
1023              
1024             =head1 LICENSE
1025              
1026             This program is free software; you may redistribute it and/or
1027             modify it under the same terms as Perl itself.
1028              
1029             See L<http://dev.perl.org/licenses/>
1030              
1031             =cut