File Coverage

blib/lib/DateTime/Format/Natural.pm
Criterion Covered Total %
statement 380 396 95.9
branch 116 134 86.5
condition 73 106 68.8
subroutine 59 59 100.0
pod 7 7 100.0
total 635 702 90.4


line stmt bran cond sub pod time code
1             package DateTime::Format::Natural;
2              
3 26     26   2471375 use strict;
  26         226  
  26         771  
4 26     26   154 use warnings;
  26         61  
  26         982  
5 26         13141 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   162 );
  26         79  
14 26     26   191 use boolean qw(true false);
  26         60  
  26         167  
15              
16 26     26   1716 use Carp qw(croak);
  26         74  
  26         1325  
17 26     26   180 use DateTime ();
  26         73  
  26         415  
18 26     26   12870 use DateTime::HiRes ();
  26         44968  
  26         612  
19 26     26   199 use DateTime::TimeZone ();
  26         61  
  26         543  
20 26     26   139 use List::MoreUtils qw(all any none);
  26         97  
  26         277  
21 26     26   36711 use Params::Validate ':all';
  26         76018  
  26         4765  
22 26     26   338 use Scalar::Util qw(blessed);
  26         90  
  26         1593  
23 26     26   207 use Storable qw(dclone);
  26         59  
  26         1400  
24              
25 26     26   168 use DateTime::Format::Natural::Utils qw(trim);
  26         56  
  26         149695  
26              
27             our $VERSION = '1.17_01';
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 10581     10581 1 144770 my $class = shift;
42              
43 10581   33     49762 my $self = bless {}, ref($class) || $class;
44              
45 10581         39052 $self->_init_check(@_);
46 10580         806332 $self->_init(@_);
47              
48 10580         28243 return $self;
49             }
50              
51             sub _init
52             {
53 10580     10580   21517 my $self = shift;
54 10580         28829 my %opts = @_;
55              
56 10580         29992 my %presets = (
57             lang => 'en',
58             format => 'd/m/y',
59             demand_future => false,
60             prefer_future => false,
61             time_zone => 'floating',
62             );
63 10580         86401 foreach my $opt (keys %presets) {
64 52900         128230 $self->{ucfirst $opt} = $presets{$opt};
65             }
66 10580         28565 foreach my $opt (keys %opts) {
67 7003 50       17323 if (defined $opts{$opt}) {
68 7003         15887 $self->{ucfirst $opt} = $opts{$opt};
69             }
70             }
71 10580   100     50302 $self->{Daytime} = $opts{daytime} || {};
72              
73 10580         39298 my $mod = join '::', (__PACKAGE__, 'Lang', uc $self->{Lang});
74 10580 50       832234 eval "require $mod" or die $@;
75              
76 10580         62740 $self->{data} = $mod->__new();
77 10580         30236 $self->{grammar_class} = $mod;
78              
79 10580         43241 $self->{mode} = '';
80             }
81              
82             sub _init_check
83             {
84 10581     10581   19035 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 1072 50   1072   64338 return true unless exists $_[1]->{prefer_future};
95 0         0 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 1091 100   1091   64032 return true unless exists $_[1]->{demand_future};
121 1         9 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   80158 my $val = shift;
132 1562 100       6106 if (blessed($val)) {
133 1         18 return $val->isa('DateTime::TimeZone');
134             }
135             else {
136 1561         2654 eval { DateTime::TimeZone->new(name => $val) };
  1561         5758  
137 1561         124410 return !$@;
138             }
139             }
140             },
141             },
142             daytime => {
143             type => HASHREF,
144             optional => true,
145             },
146             datetime => {
147             type => OBJECT,
148             optional => true,
149             callbacks => {
150             'valid object' => sub
151             {
152 26     26   1010 my $obj = shift;
153 26 50       419 blessed($obj) && $obj->isa('DateTime');
154             }
155             },
156             },
157 10581         39390 });
158             }
159              
160             sub _init_vars
161             {
162 11703     11703   21309 my $self = shift;
163              
164 11703         36889 delete @$self{qw(keyword modified postprocess)};
165             }
166              
167             sub parse_datetime
168             {
169 11703     11703 1 60418 my $self = shift;
170              
171 11703         38513 $self->_parse_init(@_);
172              
173 11703         92243 $self->{input_string} = $self->{date_string};
174              
175 11703         22854 $self->{mode} = 'parse';
176              
177 11703         21493 my $date_string = $self->{date_string};
178              
179 11703         47317 $self->_rewrite(\$date_string);
180              
181 11703         75671 my ($formatted) = $date_string =~ $self->{data}->__regexes('format');
182 11703         47576 my %count = $self->_count_separators($formatted);
183              
184 11703         31195 $self->{tokens} = [];
185 11703         25703 $self->{traces} = [];
186              
187 11703 100       36481 if ($self->_check_formatted('ymd', \%count)) {
    100          
    100          
    100          
    100          
188 271         1166 my $dt = $self->_parse_formatted_ymd($date_string, \%count);
189 271 100       1004 return $dt if blessed($dt);
190             }
191             elsif ($self->_check_formatted('md', \%count)) {
192 193         794 my $dt = $self->_parse_formatted_md($date_string);
193 193 100       696 return $dt if blessed($dt);
194              
195 192 100 100     567 if ($self->{Prefer_future} || $self->{Demand_future}) {
196 36         517 $self->_advance_future('md');
197             }
198             }
199             elsif ($date_string =~ /^(\d{4}(?:-\d{2}){0,2})T(\d{2}(?::\d{2}){0,2})$/) {
200 9         39 my ($date, $time) = ($1, $2);
201              
202 9         13 my %args;
203              
204 9         41 @args{qw(year month day)} = split /-/, $date;
205 9   100     58 $args{$_} ||= 01 foreach qw(month day);
206              
207 9         33 @args{qw(hour minute second)} = split /:/, $time;
208 9   100     41 $args{$_} ||= 00 foreach qw(minute second);
209              
210 9         67 my $valid_date = $self->_check_date(map $args{$_}, qw(year month day));
211 9         52 my $valid_time = $self->_check_time(map $args{$_}, qw(hour minute second));
212              
213 9 50 33     41 if (not $valid_date && $valid_time) {
214 0 0       0 my $type = !$valid_date ? 'date' : 'time';
215 0         0 $self->_set_failure;
216 0         0 $self->_set_error("(invalid $type)");
217 0         0 return $self->_get_datetime_object;
218             }
219              
220 9         51 $self->_set(%args);
221              
222 9         44 $self->{datetime}->truncate(to => 'second');
223 9         2745 $self->_set_truncated;
224 9         43 $self->_set_valid_exp;
225             }
226             elsif ($date_string =~ /^([+-]) (\d+?) ([a-zA-Z]+)$/x) {
227 14         83 my ($prefix, $value, $unit) = ($1, $2, lc $3);
228              
229 14         52 my %methods = (
230             '+' => '_add',
231             '-' => '_subtract',
232             );
233 14         32 my $method = $methods{$prefix};
234              
235 14 100   64   51 if (none { $unit =~ /^${_}s?$/ } @{$self->{data}->__units('ordered')}) {
  64         680  
  14         101  
236 2         9 $self->_set_failure;
237 2         14 $self->_set_error("(invalid unit)");
238 2         5 return $self->_get_datetime_object;
239             }
240 12         98 $self->$method($unit => $value);
241              
242 12         36 $self->_set_valid_exp;
243             }
244             elsif ($date_string =~ /^\d{14}$/) {
245 6         17 my %args;
246 6         46 @args{qw(year month day hour minute second)} = $date_string =~ /^(\d{4})(\d{2})(\d{2})(\d{2})(\d{2})(\d{2})$/;
247              
248 6         48 my $valid_date = $self->_check_date(map $args{$_}, qw(year month day));
249 6         43 my $valid_time = $self->_check_time(map $args{$_}, qw(hour minute second));
250              
251 6 50 33     38 if (not $valid_date && $valid_time) {
252 0 0       0 my $type = !$valid_date ? 'date' : 'time';
253 0         0 $self->_set_failure;
254 0         0 $self->_set_error("(invalid $type)");
255 0         0 return $self->_get_datetime_object;
256             }
257              
258 6         42 $self->_set(%args);
259              
260 6         30 $self->{datetime}->truncate(to => 'second');
261 6         1566 $self->_set_truncated;
262 6         26 $self->_set_valid_exp;
263             }
264             else {
265 11210         22717 @{$self->{tokens}} = split /\s+/, $date_string;
  11210         60692  
266 11210         66014 $self->{data}->__init('tokens')->($self);
267 11210         20514 $self->{count}{tokens} = @{$self->{tokens}};
  11210         34208  
268              
269 11210         31640 $self->_process;
270             }
271              
272 11699         229356 my $trace = $self->_trace_string;
273 11699 100       38682 if (defined $trace) {
274 11339         19215 @{$self->{traces}} = $trace;
  11339         34206  
275             }
276              
277 11699         33920 return $self->_get_datetime_object;
278             }
279              
280             sub _params_init
281             {
282 13170     13170   21730 my $self = shift;
283 13170         21445 my $params = pop;
284              
285 13170 50       35746 if (@_ > 1) {
286 0         0 validate(@_, { string => { type => SCALAR }});
287 0         0 my %opts = @_;
288 0         0 foreach my $opt (keys %opts) {
289 0         0 ${$params->{$opt}} = $opts{$opt};
  0         0  
290             }
291             }
292             else {
293 13170         172523 validate_pos(@_, { type => SCALAR });
294 13170         46492 (${$params->{string}}) = @_;
  13170         35886  
295             }
296              
297 13170         50921 trim($params->{string});
298             }
299              
300             sub _parse_init
301             {
302 11703     11703   19630 my $self = shift;
303              
304 11703         50849 $self->_params_init(@_, { string => \$self->{date_string} });
305              
306             my $set_datetime = sub
307             {
308 2907     2907   7117 my ($method, $args) = @_;
309              
310 2907 100 66     8939 if (exists $self->{Datetime} && $method eq 'now') {
311 24         305 $self->{datetime} = dclone($self->{Datetime});
312             }
313             else {
314             $self->{datetime} = DateTime::HiRes->$method(
315             time_zone => $self->{Time_zone},
316 2883         14603 %$args,
317             );
318             }
319 11703         59674 };
320              
321 11703 100       41217 if ($self->{running_tests}) {
322 8796         80288 $self->{datetime} = $self->{datetime_test}->clone;
323             }
324             else {
325 2907         6748 $set_datetime->('now', {});
326             }
327              
328 11703         1652992 $self->_init_vars;
329              
330 11703         35568 $self->_unset_failure;
331 11703         56694 $self->_unset_error;
332 11703         31884 $self->_unset_valid_exp;
333 11703         59232 $self->_unset_trace;
334 11703         26729 $self->_unset_truncated;
335             }
336              
337             sub parse_datetime_duration
338             {
339 1258     1258 1 213796 my $self = shift;
340              
341 1258         2558 my $duration_string;
342 1258         6601 $self->_params_init(@_, { string => \$duration_string });
343 1258         9441 my $timespan_sep = $self->{data}->__timespan('literal');
344              
345             my @date_strings = $duration_string =~ /\s+ $timespan_sep \s+/ix
346 1039         3341 ? do { $self->{duration} = true;
347 1039         8852 split /\s+ $timespan_sep \s+/ix, $duration_string }
348 1258 100       9725 : do { $self->{duration} = false;
  219         745  
349 219         1081 ($duration_string) };
350              
351 1258         2853 my $max = 2;
352              
353 1258         3074 my $shrinked = false;
354 1258 100       6151 if (@date_strings > $max) {
355 1         3 my $offset = $max;
356 1         4 splice (@date_strings, $offset);
357 1         3 $shrinked = true;
358             }
359              
360 1258         6145 $self->_rewrite_duration(\@date_strings);
361              
362 1258         8028 $self->_pre_duration(\@date_strings);
363 1258         19351 @$self{qw(state truncated_duration)} = ({}, []);
364              
365 1258         2964 my (@queue, @traces, @truncated);
366 1258         3086 foreach my $date_string (@date_strings) {
367 2297         6905 push @queue, $self->parse_datetime($date_string);
368 2297         6621 $self->_save_state(
369             valid_expression => $self->_get_valid_exp,
370             failure => $self->_get_failure,
371             error => $self->_get_error,
372             );
373 2297 100       20195 if (@{$self->{traces}}) {
  2297         6612  
374 2292         5761 push @traces, $self->{traces}[0];
375             }
376 2297 100       6402 if ($self->{running_tests}) {
377 1932         14779 push @truncated, $self->_get_truncated;
378             }
379             }
380              
381 1258         6165 $self->_post_duration(\@queue, \@traces, \@truncated);
382 1258         7749 $self->_restore_state;
383              
384 1258         5456 delete @$self{qw(duration insert state)};
385              
386 1258         2466 @{$self->{traces}} = @traces;
  1258         3758  
387 1258         2438 @{$self->{truncated_duration}} = @truncated;
  1258         3008  
388 1258         2981 $self->{input_string} = $duration_string;
389              
390 1258 100       3133 if ($shrinked) {
391 1         18 $self->_set_failure;
392 1         9 $self->_set_error("(limit of $max duration substrings exceeded)");
393             }
394              
395 1258         15071 return @queue;
396             }
397              
398             sub extract_datetime
399             {
400 209     209 1 6812 my $self = shift;
401              
402 209         391 my $extract_string;
403 209         970 $self->_params_init(@_, { string => \$extract_string });
404              
405 209         1091 $self->_unset_failure;
406 209         1014 $self->_unset_error;
407 209         624 $self->_unset_valid_exp;
408              
409 209         942 $self->{input_string} = $extract_string;
410              
411 209         620 $self->{mode} = 'extract';
412              
413 209         1138 my @expressions = $self->_extract_expressions($extract_string);
414              
415 209 100       2006 $self->_set_valid_exp if @expressions;
416              
417 209 100       2181 return wantarray ? @expressions : $expressions[0];
418             }
419              
420             sub success
421             {
422 10602     10602 1 67853 my $self = shift;
423              
424 10602 100 100     25315 return ($self->_get_valid_exp && !$self->_get_failure) ? true : false;
425             }
426              
427             sub error
428             {
429 6     6 1 73 my $self = shift;
430              
431 6 100       18 return '' if $self->success;
432              
433             my $error = sub
434             {
435 5 100 66 5   49 return undef unless defined $self->{mode} && length $self->{mode};
436 4         30 my %errors = (
437             extract => "'$self->{input_string}' cannot be extracted from",
438             parse => "'$self->{input_string}' does not parse",
439             );
440 4         15 return $errors{$self->{mode}};
441 5         129 }->();
442              
443 5 100       36 if (defined $error) {
444 4   100     13 $error .= ' ' . ($self->_get_error || '(perhaps you have some garbage?)');
445             }
446             else {
447 1         2 $error = 'neither extracting nor parsing method invoked';
448             }
449              
450 5         48 return $error;
451             }
452              
453             sub trace
454             {
455 7     7 1 49 my $self = shift;
456              
457 7 100       13 return @{$self->{traces} || []};
  7         44  
458             }
459              
460             sub _process
461             {
462 11531     11531   22035 my $self = shift;
463              
464 11531         18443 my %opts;
465              
466 11531 100       29831 if (!exists $self->{lookup}) {
467 10414         16423 foreach my $keyword (keys %{$self->{data}->__grammar('')}) {
  10414         46539  
468 697738         5367149 my $count = scalar @{$self->{data}->__grammar($keyword)->[0]};
  697738         2579533  
469 697738         1117797 push @{$self->{lookup}{$count}}, [ $keyword, false ];
  697738         1747705  
470 697738 100       2986826 if ($self->_expand_for($keyword)) {
471 197866         1751120 push @{$self->{lookup}{$count + 1}}, [ $keyword, true ];
  197866         501623  
472             }
473             }
474             }
475              
476 11531 50       139049 PARSE: foreach my $lookup (@{$self->{lookup}{$self->{count}{tokens}} || []}) {
  11531         51054  
477 100227         1360641 my ($keyword, $expandable) = @$lookup;
478              
479 100227         144342 my @grammar = @{$self->{data}->__grammar($keyword)};
  100227         498937  
480 100227         197134 my $types_entry = shift @grammar;
481              
482 100227 100       233012 @grammar = $self->_expand($keyword, $types_entry, \@grammar) if $expandable;
483              
484 100227         658984 foreach my $entry (@grammar) {
485 593840 100       3918597 my ($types, $expression) = $expandable ? @$entry : ($types_entry, $entry);
486 593840         4139002 my $valid_expression = true;
487 593840         1785390 my $definition = $expression->[0];
488 593840         1711679 my @positions = sort {$a <=> $b} keys %$definition;
  1771425         3289965  
489 593840         1018275 my (%first_stack, %rest_stack);
490 593840         968167 foreach my $pos (@positions) {
491 711418 100       1597251 if ($types->[$pos] eq 'SCALAR') {
    50          
492 68728 50       146933 if (defined $definition->{$pos}) {
493 68728 100       94457 if (${$self->_token($pos)} =~ /^$definition->{$pos}$/i) {
  68728         122074  
494 6189         16111 next;
495             }
496             else {
497 62539         148826 $valid_expression = false;
498 62539         203761 last;
499             }
500             }
501             }
502             elsif ($types->[$pos] eq 'REGEXP') {
503 642690 100       881501 if (my @captured = ${$self->_token($pos)} =~ $definition->{$pos}) {
  642690         1150476  
504 122926         309420 $first_stack{$pos} = shift @captured;
505 122926         230041 $rest_stack{$pos} = [ @captured ];
506 122926         270907 next;
507             }
508             else {
509 519764         1164411 $valid_expression = false;
510 519764         1579631 last;
511             }
512             }
513             else {
514 0         0 die "grammar error at keyword \"$keyword\" within $self->{grammar_class}: ",
515             "unknown type $types->[$pos]\n";
516             }
517             }
518 593840 100 100     1343677 if ($valid_expression && @{$expression->[2]}) {
  11537         110848  
519 8573         16516 my $i = 0;
520 8573         14649 foreach my $check (@{$expression->[2]}) {
  8573         21724  
521 10839         16901 my @pos = @{$expression->[1][$i++]};
  10839         29214  
522 10839         18518 my $error;
523 10839         38483 $valid_expression &= $check->(\%first_stack, \%rest_stack, \@pos, \$error);
524 10839 100       64816 unless ($valid_expression) {
525 366         1696 $self->_set_error("($error)");
526 366         868 last;
527             }
528             }
529             }
530 593840 100       4228677 if ($valid_expression) {
531 11171         50535 $self->_set_valid_exp;
532 11171 100       41736 my @truncate_to = @{$expression->[6]->{truncate_to} || []};
  11171         45039  
533 11171         21618 my $i = 0;
534 11171         18221 foreach my $positions (@{$expression->[3]}) {
  11171         25723  
535 19560         34061 my ($c, @values);
536 19560         38212 foreach my $pos (@$positions) {
537 24633 100       85615 my $index = ref $pos eq 'HASH' ? (keys %$pos)[0] : $pos;
538             $values[$c++] = ref $pos
539             ? $index eq 'VALUE'
540             ? $pos->{$index}
541             : $self->SUPER::_helper($pos->{$index}, $first_stack{$index})
542             : exists $first_stack{$index}
543             ? $first_stack{$index}
544 24633 100       119977 : ${$self->_token($index)};
  0 50       0  
    100          
545             }
546 19560         54231 my $worker = "SUPER::$expression->[5]->[$i]";
547 19560         97825 $self->$worker(@values, $expression->[4]->[$i++]);
548 19560         88184 $self->_truncate(shift @truncate_to);
549             }
550 11171         21797 %opts = %{$expression->[6]};
  11171         36744  
551 11171         30013 $self->{keyword} = $keyword;
552 11171         100337 last PARSE;
553             }
554             }
555             }
556              
557 11531         51050 $self->_post_process(%opts);
558             }
559              
560             sub _truncate
561             {
562 19560     19560   33952 my $self = shift;
563 19560         41838 my ($truncate_to) = @_;
564              
565 19560 100       61598 return unless defined $truncate_to;
566              
567 11819 100       23819 my @truncate_to = map { $_ =~ /_/ ? split /_/, $_ : $_ } $truncate_to;
  11819         72801  
568 11819         24141 my $i = 0;
569 11819         18750 my @units = @{$self->{data}->__units('ordered')};
  11819         76263  
570 11819         29164 my %indexes = map { $_ => $i++ } @units;
  94552         184095  
571 11819         32339 foreach my $unit (@truncate_to) {
572 20493         41437 my $index = $indexes{$unit} - 1;
573 20493 100 66     88190 if (defined $units[$index] && !exists $self->{modified}{$units[$index]}) {
574 11765         45894 $self->{datetime}->truncate(to => $unit);
575 11765         3487895 $self->_set_truncated;
576 11765         88663 last;
577             }
578             }
579             }
580              
581             sub _post_process
582             {
583 11531     11531   20421 my $self = shift;
584 11531         26544 my %opts = @_;
585              
586 11531         23375 delete $opts{truncate_to};
587              
588 11531 50 100     41077 if (($self->{Prefer_future} || $self->{Demand_future})
      66        
      66        
589             && (exists $opts{advance_future} && $opts{advance_future})
590             ) {
591 2070         40407 $self->_advance_future;
592             }
593             }
594              
595             sub _advance_future
596             {
597 2106     2106   3637 my $self = shift;
598 2106         4481 my %advance = map { $_ => true } @_;
  36         88  
599              
600 2106         3466 my %modified = map { $_ => true } keys %{$self->{modified}};
  6156         18044  
  2106         6990  
601             my $token_contains = sub
602             {
603 2520     2520   39518 my ($identifier) = @_;
604             return any {
605 27066         66077 my $data = $_;
606             any {
607 43158         70664 my $token = $_;
608 43158         235231 $token =~ /^$data$/i;
609 27066         65919 } @{$self->{tokens}}
  27066         60134  
610 2520         11160 } @{$self->{data}->{$identifier}};
  2520         9822  
611 2106         17157 };
612              
613             my $now = exists $self->{Datetime}
614             ? dclone($self->{Datetime})
615 2106 100       9651 : DateTime::HiRes->now(time_zone => $self->{Time_zone});
616              
617 2106     1530   1043987 my $day_of_week = sub { $_[0]->_Day_of_Week(map $_[0]->{datetime}->$_, qw(year month day)) };
  1530         51289  
618              
619 2106         7166 my $skip_weekdays = false;
620              
621 2106 50 33 4324   13770 if ((all { /^(?:(?:nano)?second|minute|hour)$/ } keys %modified)
  4324 100 66     25345  
    100 100        
    100 66        
    100 66        
    100 66        
      66        
      100        
      33        
      66        
      66        
      33        
      100        
      66        
      33        
      66        
      33        
      66        
      33        
622             && (exists $self->{modified}{hour} && $self->{modified}{hour} == 1)
623             && (($self->{Prefer_future} && $self->{datetime} < $now)
624             || ($self->{Demand_future} && $self->{datetime} <= $now))
625             ) {
626 234         25032 $self->{postprocess}{day} = 1;
627             }
628             elsif (sub {
629 1872 100   1872   26167 return false unless @{$self->{tokens}} == 2;
  1872         6745  
630 1398         10802 my ($day, $weekday) = map $self->{data}->__RE($_), qw(day weekday);
631 1398 100 100     10077 if ($self->{tokens}->[0] =~ $day
632             && $self->{tokens}->[1] =~ $weekday) {
633 36         133 $skip_weekdays = true;
634 36         143 return true;
635             }
636 1362         3875 return false;
637             }->()
638 108     108   932 && (all { /^(?:day|month|year)$/ } keys %modified)
639             && (($self->{Prefer_future} && $self->{datetime}->day < $now->day)
640             || ($self->{Demand_future} && $self->{datetime}->day <= $now->day))
641             ) {
642 18         664 $self->{postprocess}{week} = 4;
643             }
644             elsif (($token_contains->('weekdays_all') && !$skip_weekdays)
645             && (exists $self->{modified}{day} && $self->{modified}{day} == 1)
646             && (($self->{Prefer_future} && $day_of_week->($self) < $now->wday)
647             || ($self->{Demand_future} && $day_of_week->($self) <= $now->wday))
648             ) {
649 1188         17872 $self->{postprocess}{day} = 7;
650             }
651             elsif (($token_contains->('months_all') || $advance{md})
652 156     156   2016 && (all { /^(?:day|month)$/ } keys %modified)
653             && (exists $self->{modified}{month} && $self->{modified}{month} == 1)
654             && (exists $self->{modified}{day}
655             ? $self->{modified}{day} == 1
656             ? true : false
657             : true)
658             && (($self->{Prefer_future} && $self->{datetime}->day_of_year < $now->day_of_year)
659             || ($self->{Demand_future} && $self->{datetime}->day_of_year <= $now->day_of_year))
660             ) {
661 72         3286 $self->{postprocess}{year} = 1;
662             }
663             }
664              
665             sub _token
666             {
667 711418     711418   1018238 my $self = shift;
668 711418         1150946 my ($pos) = @_;
669              
670 711418         1009397 my $str = '';
671 711418         1398549 my $token = $self->{tokens}->[0 + $pos];
672              
673 711418 50       3784546 return defined $token
674             ? \$token
675             : \$str;
676             }
677              
678 19560     19560   31077 sub _register_trace { push @{$_[0]->{trace}}, (caller(1))[3] }
  19560         168476  
679 11703     11703   19158 sub _unset_trace { @{$_[0]->{trace}} = () }
  11703         32099  
680              
681 2652     2652   18912 sub _get_error { $_[0]->{error} }
682 372     372   799 sub _set_error { $_[0]->{error} = $_[1] }
683 11914     11914   26772 sub _unset_error { $_[0]->{error} = undef }
684              
685 12538     12538   107071 sub _get_failure { $_[0]->{failure} }
686 6     6   29 sub _set_failure { $_[0]->{failure} = true }
687 11914     11914   27921 sub _unset_failure { $_[0]->{failure} = false }
688              
689 12899     12899   46193 sub _get_valid_exp { $_[0]->{valid_expression} }
690 11868     11868   25757 sub _set_valid_exp { $_[0]->{valid_expression} = true }
691 12236     12236   25851 sub _unset_valid_exp { $_[0]->{valid_expression} = false }
692              
693 10779     10779   185838 sub _get_truncated { $_[0]->{truncated} }
694 12242     12242   36310 sub _set_truncated { $_[0]->{truncated} = true }
695 12024     12024   24500 sub _unset_truncated { $_[0]->{truncated} = false }
696              
697             sub _get_datetime_object
698             {
699 11703     11703   19820 my $self = shift;
700              
701             my $dt = DateTime->new(
702             time_zone => $self->{datetime}->time_zone,
703             year => $self->{datetime}->year,
704             month => $self->{datetime}->month,
705             day => $self->{datetime}->day_of_month,
706             hour => $self->{datetime}->hour,
707             minute => $self->{datetime}->minute,
708             second => $self->{datetime}->second,
709             nanosecond => $self->{datetime}->nanosecond,
710 11703         38410 );
711              
712 11703         3758604 foreach my $unit (keys %{$self->{postprocess}}) {
  11703         46700  
713 1512         7184 $dt->add("${unit}s" => $self->{postprocess}{$unit});
714             }
715              
716 11703         1553148 return $dt;
717             }
718              
719             # solely for testing purpose
720             sub _set_datetime
721             {
722 7806     7806   36343 my $self = shift;
723 7806         17821 my ($time, $tz) = @_;
724              
725 7806   100     55048 $self->{datetime_test} = DateTime->new(
726             time_zone => $tz || 'floating',
727             %$time,
728             );
729 7806         3004569 $self->{running_tests} = true;
730             }
731              
732             1;
733             __END__
734              
735             =encoding ISO8859-1
736              
737             =head1 NAME
738              
739             DateTime::Format::Natural - Parse informal natural language date/time strings
740              
741             =head1 SYNOPSIS
742              
743             use DateTime::Format::Natural;
744              
745             $parser = DateTime::Format::Natural->new;
746              
747             $dt = $parser->parse_datetime($date_string);
748             @dt = $parser->parse_datetime_duration($date_string);
749              
750             $date_string = $parser->extract_datetime($extract_string);
751             @date_strings = $parser->extract_datetime($extract_string);
752              
753             if ($parser->success) {
754             # operate on $dt/@dt, for example:
755             print $dt->strftime('%d.%m.%Y %H:%M:%S'), "\n";
756             } else {
757             warn $parser->error;
758             }
759              
760             @traces = $parser->trace;
761              
762             # examples
763              
764             12:14 PM
765             next tuesday at 2am
766             tomorrow morning
767             4pm yesterday
768             10 weeks ago
769              
770             1st tuesday last november
771             2nd friday in august
772             final thursday in april
773              
774             for 3 hours
775             monday to friday
776             1 April 10 am to 1 May 8am
777              
778             jan 24, 2011 12:00
779              
780             =head1 DESCRIPTION
781              
782             C<DateTime::Format::Natural> parses informal natural language date/time strings.
783             In addition, parsable date/time substrings may be extracted from ordinary strings.
784              
785             =head1 CONSTRUCTOR
786              
787             =head2 new
788              
789             Creates a new C<DateTime::Format::Natural> object. Arguments to C<new()> are options and
790             not necessarily required.
791              
792             $parser = DateTime::Format::Natural->new(
793             datetime => DateTime->new(...),
794             lang => 'en',
795             format => 'mm/dd/yy',
796             prefer_future => [0|1],
797             demand_future => [0|1],
798             time_zone => 'floating',
799             daytime => { morning => 06,
800             afternoon => 13,
801             evening => 20,
802             },
803             );
804              
805             =over 4
806              
807             =item * C<datetime>
808              
809             Overrides the present now with a L<DateTime> object provided.
810              
811             =item * C<lang>
812              
813             Contains the language selected, currently limited to C<en> (english).
814             Defaults to 'C<en>'.
815              
816             =item * C<format>
817              
818             Specifies the format of numeric dates.
819              
820             The format is used to influence how numeric dates are parsed. Given two
821             numbers separated by a slash, the month/day order expected comes from
822             this option. If there is a third number, this option describes where
823             to expect the year. When this format can't be used to interpret the
824             date, some unambiguous dates may be parsed, but there is no form
825             guarantee.
826              
827             Current supported "month/day" formats: C<dd/mm>, C<mm/dd>.
828              
829             Current supported "year/month/day" formats (with slashes): C<dd/mm/yy>,
830             C<dd/mm/yyyy>, C<mm/dd/yyyy>, C<yyyy/mm/dd>.
831              
832             Note that all of the above formats with three units do also parse
833             with dots or dashes as format separators.
834              
835             Furthermore, formats can be abbreviated as long as they remain
836             unambiguous.
837              
838             Defaults to 'C<d/m/y>'.
839              
840             =item * C<prefer_future>
841              
842             Prefers future time and dates. Accepts a boolean, defaults to false.
843              
844             =item * C<demand_future>
845              
846             Demands future time and dates. Similar to C<prefer_future>, but stronger.
847             Accepts a boolean, defaults to false.
848              
849             =item * C<time_zone>
850              
851             The time zone to use when parsing and for output. Accepts any time zone
852             recognized by L<DateTime>. Defaults to 'floating'.
853              
854             =item * C<daytime>
855              
856             A hash reference consisting of customized daytime hours,
857             which may be selectively changed.
858              
859             =back
860              
861             =head1 METHODS
862              
863             =head2 parse_datetime
864              
865             Returns a L<DateTime> object constructed from a natural language date/time string.
866              
867             $dt = $parser->parse_datetime($date_string);
868             $dt = $parser->parse_datetime(string => $date_string);
869              
870             =over 4
871              
872             =item * C<string>
873              
874             The date string.
875              
876             =back
877              
878             =head2 parse_datetime_duration
879              
880             Returns one or two L<DateTime> objects constructed from a natural language
881             date/time string which may contain timespans/durations. I<Same> interface
882             and options as C<parse_datetime()>, but should be explicitly called in
883             list context.
884              
885             @dt = $parser->parse_datetime_duration($date_string);
886             @dt = $parser->parse_datetime_duration(string => $date_string);
887              
888             =head2 extract_datetime
889              
890             Returns parsable date/time substrings (also known as expressions) extracted
891             from the string provided; in scalar context only the first parsable substring
892             is returned, whereas in list context all parsable substrings are returned.
893             Each extracted substring can then be passed to the C<parse_datetime()>/
894             C<parse_datetime_duration()> methods.
895              
896             $date_string = $parser->extract_datetime($extract_string);
897             @date_strings = $parser->extract_datetime($extract_string);
898             # or
899             $date_string = $parser->extract_datetime(string => $extract_string);
900             @date_strings = $parser->extract_datetime(string => $extract_string);
901              
902             =head2 success
903              
904             Returns a boolean indicating success or failure for parsing the date/time
905             string given.
906              
907             =head2 error
908              
909             Returns the error message if the parsing did not succeed.
910              
911             =head2 trace
912              
913             Returns one or two strings with the grammar keyword for the valid
914             expression parsed, traces of methods which were called within the Calc
915             class and a summary how often certain units have been modified. More than
916             one string is commonly returned for durations. Useful as a debugging aid.
917              
918             =head1 GRAMMAR
919              
920             The grammar handling has been rewritten to be easily extendable and hence
921             everybody is encouraged to propose sensible new additions and/or changes.
922              
923             See the class L<DateTime::Format::Natural::Lang::EN> if you're intending
924             to hack a bit on the grammar guts.
925              
926             =head1 EXAMPLES
927              
928             See the class L<DateTime::Format::Natural::Lang::EN> for an overview of
929             currently valid input.
930              
931             =head1 BUGS & CAVEATS
932              
933             C<parse_datetime()>/C<parse_datetime_duration()> always return one or two
934             DateTime objects regardless whether the parse was successful or not. In
935             case no valid expression was found or a failure occurred, an unaltered
936             DateTime object with its initial values (most often the "current" now) is
937             likely to be returned. It is therefore recommended to use C<success()> to
938             assert that the parse did succeed (at least, for common uses), otherwise
939             the absence of a parse failure cannot be guaranteed.
940              
941             C<parse_datetime()> is not capable of handling durations.
942              
943             =head1 CREDITS
944              
945             Thanks to Tatsuhiko Miyagawa for the initial inspiration. See Miyagawa's journal
946             entry L<http://use.perl.org/~miyagawa/journal/31378> for more information.
947              
948             Furthermore, thanks to (in order of appearance) who have contributed
949             valuable suggestions and patches:
950              
951             Clayton L. Scott
952             Dave Rolsky
953             CPAN Author 'SEKIMURA'
954             mike (pulsation)
955             Mark Stosberg
956             Tuomas Jormola
957             Cory Watson
958             Urs Stotz
959             Shawn M. Moore
960             Andreas J. König
961             Chia-liang Kao
962             Jonny Schulz
963             Jesse Vincent
964             Jason May
965             Pat Kale
966             Ankur Gupta
967             Alex Bowley
968             Elliot Shank
969             Anirvan Chatterjee
970             Michael Reddick
971             Christian Brink
972             Giovanni Pensa
973             Andrew Sterling Hanenkamp
974             Eric Wilhelm
975             Kevin Field
976             Wes Morgan
977             Vladimir Marek
978             Rod Taylor
979             Tim Esselens
980             Colm Dougan
981             Chifung Fan
982             Xiao Yafeng
983             Roman Filippov
984             David Steinbrunner
985             Debian Perl Group
986             Tim Bunce
987             Ricardo Signes
988             Felix Ostmann
989             Jörn Clausen
990             Jim Avera
991             Olaf Alders
992             Karen Etheridge
993              
994             =head1 SEE ALSO
995              
996             L<dateparse>, L<DateTime>, L<Date::Calc>, L<http://datetime.perl.org>
997              
998             =head1 AUTHOR
999              
1000             Steven Schubiger <schubiger@cpan.org>
1001              
1002             =head1 LICENSE
1003              
1004             This program is free software; you may redistribute it and/or
1005             modify it under the same terms as Perl itself.
1006              
1007             See L<http://dev.perl.org/licenses/>
1008              
1009             =cut