File Coverage

blib/lib/DateTime/Format/Alami.pm
Criterion Covered Total %
statement 244 344 70.9
branch 94 126 74.6
condition 32 48 66.6
subroutine 34 50 68.0
pod 3 31 9.6
total 407 599 67.9


line stmt bran cond sub pod time code
1             package DateTime::Format::Alami;
2              
3             our $DATE = '2017-07-10'; # DATE
4             our $VERSION = '0.16'; # VERSION
5              
6 4     4   2712 use 5.014000;
  4         21  
7 4     4   27 use strict;
  4         11  
  4         101  
8 4     4   25 use warnings;
  4         9  
  4         140  
9 4     4   22022 use Log::ger;
  4         700  
  4         54  
10              
11 4     4   6342 use Role::Tiny;
  4         12  
  4         36  
12              
13             my @short_mons = qw(jan feb mar apr may jun jul aug sep oct nov dec);
14             my @dow = qw(monday tuesday wednesday thursday friday saturday sunday);
15              
16             requires 'o_num';
17             requires '_parse_num';
18              
19             requires 'w_year';
20             requires 'w_month';
21             requires 'w_week';
22             requires 'w_day';
23             requires 'w_hour';
24             requires 'w_minute';
25             requires 'w_second';
26              
27             requires "w_$_" for @short_mons;
28             requires "w_$_" for @dow;
29              
30             requires 'p_now';
31             requires 'p_today';
32             requires 'p_yesterday';
33             requires 'p_tomorrow';
34             requires 'p_dateymd';
35             requires 'p_dateym';
36             requires 'o_date';
37             requires 'p_dur_ago';
38             requires 'p_dur_later';
39             requires 'p_which_dow';
40             requires 'p_time';
41             requires 'p_date_time';
42              
43             our ($m, $o);
44             sub new {
45 7     7 1 109 my $class = shift;
46 7 50       31 if ($class eq __PACKAGE__) {
47 0         0 die "Use one of the DateTime::Format::Alami::* instead, ".
48             "e.g. DateTime::Format::Alami::EN";
49             }
50 7         25 my $self = bless {}, $class;
51 4     4   1873 no strict 'refs';
  4         10  
  4         3445  
52 7 50 33     18 unless (${"$class\::RE_DT"} && ${"$class\::RE_DUR"}) {
  7         58  
  7         74  
53 0         0 require Class::Inspector;
54 0         0 require Data::Graph::Util;
55              
56 0         0 my $meths = Class::Inspector->methods($class);
57 0         0 my %pats; # key = "p_..."
58             my %pat_lengths; # key = "p_..."
59 0         0 my %graph;
60 0         0 for my $meth (@$meths) {
61 0 0       0 next unless $meth =~ /^(odur|o|pdur|p)_/;
62 0         0 my $pat = $self->$meth;
63 0         0 my $is_p = $meth =~ /^p_/;
64 0         0 my $is_pdur = $meth =~ /^pdur_/;
65 0         0 $pat =~ s/<(\w+)>/push @{$graph{$meth}}, $1; "(?\&$1)"/eg;
  0         0  
  0         0  
  0         0  
66 0         0 my $action_meth = $meth;
67 0 0       0 if ($is_pdur) { $action_meth =~ s/^pdur_/adur_/ } else { $action_meth =~ s/^p_/a_/ }
  0         0  
  0         0  
68             #my $before_meth = $meth; $before_meth =~ s/^p_/before_p_/;
69             #$before_meth = undef unless $is_p && $self->can($before_meth);
70             $pat = join(
71             "",
72             "(",
73             #($before_meth ? "(?{ ".($ENV{DEBUG} ? "say \"invoking $before_meth()\";" : "")."\$DateTime::Format::Alami::o->$before_meth(\$DateTime::Format::Alami::m) })" : ""),
74             ($is_p || $is_pdur ? "\\b $pat \\b" : $pat), ")",
75              
76             # we capture ourselves instead of relying on named capture
77             # because subpattern capture are discarded
78             "(?{ \$DateTime::Format::Alami::m->{$meth} = \$^N })",
79              
80 0 0 0     0 ($is_p || $is_pdur ? "(?{ ".($ENV{DEBUG} ? "say \"invoking $action_meth(\$^N)\";" : "")."\$DateTime::Format::Alami::o->{_pat} = \"$meth\"; \$DateTime::Format::Alami::o->$action_meth(\$DateTime::Format::Alami::m) })" : ""),
    0 0        
    0          
81             );
82 0         0 $pats{$meth} = $pat;
83 0         0 $pat_lengths{$meth} = length($pat);
84             }
85 0         0 my @pat_names_by_deps = Data::Graph::Util::toposort(\%graph);
86 0         0 my %pat_name_dep_orders = map { $pat_names_by_deps[$_] => $_ }
  0         0  
87             0..$#pat_names_by_deps;
88 0         0 my @pat_names = sort {(
89             ($pat_name_dep_orders{$a} // 9999) <=>
90             ($pat_name_dep_orders{$b} // 9999)
91             ||
92 0 0 0     0 $pat_lengths{$b} <=> $pat_lengths{$a}) } keys %pats;
      0        
93 0 0       0 my $nl = $ENV{DEBUG} ? "\n" : "";
94             my $re_dt = join(
95             "",
96             "(?&top)", $nl,
97             #"(?&p_dateymd)", $nl, # testing
98             "(?(DEFINE)", $nl,
99             "(?<top>", join("|",
100 0         0 map {"(?&$_)"} grep {/^p_/} @pat_names), ")$nl",
  0         0  
101 0         0 (map { "(?<$_> $pats{$_})$nl" } grep {/^(o|p)_/} @pat_names),
  0         0  
  0         0  
102             ")", # end of define
103             );
104             my $re_dur = join(
105             "",
106             "(?&top)", $nl,
107             #"(?&pdur_dur)", $nl, # testing
108             "(?(DEFINE)", $nl,
109             "(?<top>", join("|",
110 0         0 map {"(?&$_)"} grep {/^pdur_/} @pat_names), ")$nl",
  0         0  
111 0         0 (map { "(?<$_> $pats{$_})$nl" } grep {/^(odur|pdur)_/} @pat_names),
  0         0  
  0         0  
112             ")", # end of define
113             );
114             {
115 4     4   39 use re 'eval';
  4         10  
  4         1554  
  0         0  
116 0         0 ${"$class\::RE_DT"} = qr/$re_dt/ix;
  0         0  
117 0         0 ${"$class\::RE_DUR"} = qr/$re_dur/ix;
  0         0  
118             }
119             }
120 7 50       16 unless (${"$class\::MAPS"}) {
  7         47  
121 0         0 my $maps = {};
122             # month names -> num
123             {
124 0         0 my $i = 0;
125 0         0 for my $m (@short_mons) {
126 0         0 ++$i;
127 0         0 my $meth = "w_$m";
128 0         0 for (@{ $self->$meth }) {
  0         0  
129 0         0 $maps->{months}{$_} = $i;
130             }
131             }
132             }
133             # day-of-week names -> num (monday=1, sunday=7)
134             {
135 0         0 my $i = 0;
  0         0  
  0         0  
136 0         0 for my $m (@dow) {
137 0         0 ++$i;
138 0         0 my $meth = "w_$m";
139 0         0 for (@{ $self->$meth }) {
  0         0  
140 0         0 $maps->{dow}{$_} = $i;
141             }
142             }
143             }
144 0         0 ${"$class\::MAPS"} = $maps;
  0         0  
145             }
146              
147             # _time_zone is old name (<= 0.11) will be removed later
148 7   33     71 $self->{time_zone} //= $self->{_time_zone};
149              
150 7         21 $self;
151             }
152              
153             sub _reset {
154 116     116   285 my $self = shift;
155 116         336 undef $self->{_pat};
156 116         495 undef $self->{_dt};
157 116         332 undef $self->{_uses_time};
158             }
159              
160             sub parse_datetime {
161 4     4   34 no strict 'refs';
  4         30  
  4         3817  
162              
163             # we require DateTime here, for all the a_* methods
164 101     101 1 48284 require DateTime;
165              
166 101         1103344 my ($self, $str, $opts) = @_;
167              
168             # allow calling as static method
169 101 100       457 unless (ref $self) { $self = $self->new }
  2         12  
170              
171 101   100     432 $opts //= {};
172 101   100     856 $opts->{format} //= 'DateTime';
173             #$opts->{prefers} //= 'nearest';
174 101   100     662 $opts->{returns} //= 'first';
175              
176 101 100       532 local $self->{time_zone} = $opts->{time_zone} if $opts->{time_zone};
177              
178             # we need /o to avoid repeated regcomp, but we need to make it work with all
179             # subclasses, so we use eval() here.
180 101 100       262 unless (defined *{ref($self).'::_code_match_dt'}) {
  101         869  
181 4     116   436 *{ref($self).'::_code_match_dt'} = eval "sub { \$_[0] =~ /(\$".ref($self)."::RE_DT)/go; \$1 }";
  4         36  
  116         5966  
  116         36136  
182 4 50       22 die if $@;
183             }
184              
185 101         345 $o = $self;
186 101         258 my @res;
187 101         237 while (1) {
188 116         543 $o->_reset;
189 116         335 $m = {};
190 116 100       511 my $match = &{ref($self).'::_code_match_dt'}($str) or last;
  116         4345  
191 102 100       736 $o->{_dt}->truncate(to=>'day') unless $o->{_uses_time};
192             my $res = {
193             verbatim => $match,
194             pattern => $o->{_pat},
195 102         28531 pos => pos($str) - length($match),
196             m => {%$m},
197             };
198 102 100       528 $res->{uses_time} = $o->{_uses_time} ? 1:0;
199 102         364 $res->{DateTime} = $o->{_dt};
200             $res->{epoch} = $o->{_dt}->epoch if
201 102 100 100     875 $opts->{format} eq 'combined' || $opts->{format} eq 'epoch';
202 102         403 push @res, $res;
203 102 100       462 last if $opts->{returns} eq 'first';
204             }
205              
206 101 100       491 die "Can't parse date '$str'" unless @res;
207              
208 92 100       354 @res = ($res[-1]) if $opts->{returns} eq 'last';
209              
210 92 100       531 if ($opts->{returns} =~ /\A(?:all_cron|earliest|latest)\z/) {
211             # sort chronologically, note that by this time the DateTime module
212             # should already have been loaded
213             @res = sort {
214 3         20 DateTime->compare($a->{DateTime}, $b->{DateTime})
215 9         498 } @res;
216             }
217              
218 92 100       588 if ($opts->{format} eq 'DateTime') {
    100          
    100          
219 84         238 @res = map { $_->{DateTime} } @res;
  84         556  
220             } elsif ($opts->{format} eq 'epoch') {
221 1         5 @res = map { $_->{epoch} } @res;
  1         9  
222             } elsif ($opts->{format} eq 'verbatim') {
223 6         21 @res = map { $_->{verbatim} } @res;
  14         91  
224             }
225              
226 92 100       769 if ($opts->{returns} =~ /\A(?:all|all_cron)\z/) {
    100          
    50          
227 2         11 return \@res;
228             } elsif ($opts->{returns} =~ /\A(?:first|earliest)\z/) {
229 88         678 return $res[0];
230             } elsif ($opts->{returns} =~ /\A(?:last|latest)\z/) {
231 2         11 return $res[-1];
232             } else {
233 0         0 die "Unknown returns option '$opts->{returns}'";
234             }
235             }
236              
237             sub _reset_dur {
238 32     32   108 my $self = shift;
239 32         90 undef $self->{_pat};
240 32         76 undef $self->{_dtdur};
241             }
242              
243             sub parse_datetime_duration {
244             # we require DateTime here, for all the adur_* methods
245 17     17 1 35416 require DateTime;
246 17         80 require DateTime::Duration;
247              
248 4     4   45 no strict 'refs';
  4         20  
  4         5836  
249              
250 17         58 my ($self, $str, $opts) = @_;
251              
252             # allow calling as static method
253 17 100       71 unless (ref $self) { $self = $self->new }
  2         8  
254              
255 17   100     101 $opts //= {};
256 17   100     99 $opts->{format} //= 'Duration';
257 17   100     105 $opts->{returns} //= 'first';
258              
259             # we need /o to avoid repeated regcomp, but we need to make it work with all
260             # subclasses, so we use eval() here.
261 17 100       30 unless (defined *{ref($self).'::_code_match_dur'}) {
  17         133  
262 4     32   391 *{ref($self).'::_code_match_dur'} = eval "sub { \$_[0] =~ /(\$".ref($self)."::RE_DUR)/go; \$1 }";
  4         100  
  32         906  
  32         3377  
263 4 50       23 die if $@;
264             }
265              
266 17         42 $o = $self;
267 17         101 my @res;
268 17         44 while (1) {
269 32         113 $o->_reset_dur;
270 32         100 $m = {};
271 32 100       91 my $match = &{ref($self).'::_code_match_dur'}($str) or last;
  32         861  
272             my $res = {
273             verbatim => $match,
274             pattern => $o->{_pat},
275 24         210 pos => pos($str) - length($match),
276             m => {%$m},
277             };
278 24         69 $res->{Duration} = $o->{_dtdur};
279 24 100 100     167 if ($opts->{format} eq 'combined' || $opts->{format} eq 'seconds') {
280 2         5 my $d = $o->{_dtdur};
281             $res->{seconds} =
282 2         7 $d->years * 365.25*86400 +
283             $d->months * 30.4375*86400 +
284             $d->weeks * 7*86400 +
285             $d->days * 86400 +
286             $d->hours * 3600 +
287             $d->minutes * 60 +
288             $d->seconds +
289             $d->nanoseconds * 1e-9;
290             }
291 24         486 push @res, $res;
292 24 100       80 last if $opts->{returns} eq 'first';
293             }
294              
295 17 100       92 die "Can't parse duration" unless @res;
296              
297 14 100       55 @res = ($res[-1]) if $opts->{returns} eq 'last';
298              
299             # XXX support returns largest, smallest, all_sorted
300 14 100       66 if ($opts->{returns} =~ /\A(?:all_sorted|largest|smallest)\z/) {
301 3         18 my $base_dt = DateTime->now;
302             # sort from smallest to largest
303             @res = sort {
304 3         892 DateTime::Duration->compare($a->{Duration}, $b->{Duration}, $base_dt)
  9         8119  
305             } @res;
306             }
307              
308 14 100       3850 if ($opts->{format} eq 'Duration') {
    100          
    100          
309 6         21 @res = map { $_->{Duration} } @res;
  6         42  
310             } elsif ($opts->{format} eq 'seconds') {
311 1         3 @res = map { $_->{seconds} } @res;
  1         6  
312             } elsif ($opts->{format} eq 'verbatim') {
313 6         15 @res = map { $_->{verbatim} } @res;
  14         53  
314             }
315              
316 14 100       115 if ($opts->{returns} =~ /\A(?:all|all_sorted)\z/) {
    100          
    50          
317 2         9 return \@res;
318             } elsif ($opts->{returns} =~ /\A(?:first|smallest)\z/) {
319 10         56 return $res[0];
320             } elsif ($opts->{returns} =~ /\A(?:last|largest)\z/) {
321 2         10 return $res[-1];
322             } else {
323 0         0 die "Unknown returns option '$opts->{returns}'";
324             }
325             }
326              
327 0     0 0 0 sub o_dayint { "(?:[12][0-9]|3[01]|0?[1-9])" }
328              
329 0     0 0 0 sub o_monthint { "(?:0?[1-9]|1[012])" }
330              
331 0     0 0 0 sub o_year2int { "(?:[0-9]{2})" }
332              
333 0     0 0 0 sub o_year4int { "(?:[0-9]{4})" }
334              
335 0     0 0 0 sub o_yearint { "(?:[0-9]{4}|[0-9]{2})" }
336              
337 0     0 0 0 sub o_hour { "(?:[0-9][0-9]?)" }
338              
339 0     0 0 0 sub o_minute { "(?:[0-9][0-9]?)" }
340              
341 0     0 0 0 sub o_second { "(?:[0-9][0-9]?)" }
342              
343             sub o_monthname {
344 0     0 0 0 my $self = shift;
345             "(?:" . join(
346             "|",
347 0         0 (map {my $meth="w_$_"; @{ $self->$meth }} @short_mons)
  0         0  
  0         0  
  0         0  
348             ) . ")";
349             }
350              
351             sub o_dow {
352 0     0 0 0 my $self = shift;
353             "(?:" . join(
354             "|",
355 0         0 (map {my $meth="w_$_"; @{ $self->$meth }} @dow)
  0         0  
  0         0  
  0         0  
356             ) . ")";
357             }
358              
359             sub o_durwords {
360 5     5 0 11 my $self = shift;
361             "(?:" . join(
362             "|",
363 5         27 @{ $self->w_year }, @{ $self->w_month }, @{ $self->w_week },
  5         21  
  5         24  
364 5         22 @{ $self->w_day },
365 5         13 @{ $self->w_hour }, @{ $self->w_minute }, @{ $self->w_second },
  5         22  
  5         20  
  5         23  
366             ) . ")";
367             }
368              
369             sub o_dur {
370 0     0 0 0 my $self = shift;
371 0         0 "(?:(" . $self->o_num . "\\s*" . $self->o_durwords . "\\s*(?:,\\s*)?)+)";
372             }
373              
374             sub odur_dur {
375 0     0 0 0 my $self = shift;
376 0         0 $self->o_dur;
377             }
378              
379             sub pdur_dur {
380 0     0 0 0 my $self = shift;
381 0         0 "(?:<odur_dur>)";
382             }
383              
384             # durations less than a day
385             sub o_timedurwords {
386 0     0 0 0 my $self = shift;
387             "(?:" . join(
388             "|",
389 0         0 @{ $self->w_hour }, @{ $self->w_minute }, @{ $self->w_second },
  0         0  
  0         0  
  0         0  
390             ) . ")";
391             }
392              
393             sub o_timedur {
394 0     0 0 0 my $self = shift;
395 0         0 "(?:(" . $self->o_num . "\\s*" . $self->o_timedurwords . "\\s*(?:,\\s*)?)+)";
396             }
397              
398             sub _parse_dur {
399 4     4   2677 use experimental 'smartmatch';
  4         18594  
  4         45  
400              
401 30     30   75 my ($self, $str) = @_;
402              
403             #say "D:dur=$str";
404 30         62 my %args;
405 30 100       101 unless ($self->{_cache_re_parse_dur}) {
406 5         30 my $o_num = $self->o_num;
407 5         21 my $o_dw = $self->o_durwords;
408 5         562 $self->{_cache_re_parse_dur} = qr/($o_num)\s*($o_dw)/ix;
409             }
410 30 100       113 unless ($self->{_cache_w_second}) {
411 5         1728 $self->{_cache_w_second} = $self->w_second;
412 5         24 $self->{_cache_w_minute} = $self->w_minute;
413 5         41 $self->{_cache_w_hour} = $self->w_hour;
414 5         21 $self->{_cache_w_day} = $self->w_day;
415 5         1472 $self->{_cache_w_week} = $self->w_week;
416 5         19 $self->{_cache_w_month} = $self->w_month;
417 5         19 $self->{_cache_w_year} = $self->w_year;
418             }
419 30         300 while ($str =~ /$self->{_cache_re_parse_dur}/g) {
420 40         150 my ($n, $unit) = ($1, $2);
421 40         147 $n = $self->_parse_num($n);
422 40 100       1386 if ($unit ~~ $self->{_cache_w_second}) {
    100          
    100          
    50          
    0          
    0          
    0          
423 6         16 $args{seconds} = $n;
424 6         26 $self->{_uses_time} = 1;
425             } elsif ($unit ~~ $self->{_cache_w_minute}) {
426 8         23 $args{minutes} = $n;
427 8         43 $self->{_uses_time} = 1;
428             } elsif ($unit ~~ $self->{_cache_w_hour}) {
429 9         29 $args{hours} = $n;
430 9         75 $self->{_uses_time} = 1;
431             } elsif ($unit ~~ $self->{_cache_w_day}) {
432 17         112 $args{days} = $n;
433             } elsif ($unit ~~ $self->{_cache_w_week}) {
434 0         0 $args{weeks} = $n;
435             } elsif ($unit ~~ $self->{_cache_w_month}) {
436 0         0 $args{months} = $n;
437             } elsif ($unit ~~ $self->{_cache_w_year}) {
438 0         0 $args{years} = $n;
439             }
440             }
441 30         191 DateTime::Duration->new(%args);
442             }
443              
444             sub _now_if_unset {
445 14     14   40 my $self = shift;
446 14 100       83 $self->a_now unless $self->{_dt};
447             }
448              
449             sub _today_if_unset {
450 0     0   0 my $self = shift;
451 0 0       0 $self->a_today unless $self->{_dt};
452             }
453              
454             sub a_now {
455 23     23 0 61 my $self = shift;
456             $self->{_dt} = DateTime->now(
457 23         173 (time_zone => $self->{time_zone}) x !!defined($self->{time_zone}),
458             );
459 23         12654 $self->{_uses_time} = 1;
460             }
461              
462             sub a_today {
463 198     198 0 480 my $self = shift;
464             $self->{_dt} = DateTime->today(
465 198         1105 (time_zone => $self->{time_zone}) x !!defined($self->{time_zone}),
466             );
467 198         203805 $self->{_uses_time} = 0;
468             }
469              
470             sub a_yesterday {
471 10     10 0 27 my $self = shift;
472 10         46 $self->a_today;
473 10         48 $self->{_dt}->subtract(days => 1);
474             }
475              
476             sub a_tomorrow {
477 8     8 0 21 my $self = shift;
478 8         37 $self->a_today;
479 8         48 $self->{_dt}->add(days => 1);
480             }
481              
482             sub a_dateymd {
483 147     147 0 401 my ($self, $m) = @_;
484 147         582 $self->a_today;
485 147   100     1047 my $y0 = $m->{o_yearint} // $m->{o_year4int} // $m->{o_year2int};
      100        
486 147 100       522 if (defined $y0) {
487 79         177 my $year;
488 79 100       282 if (length($y0) == 2) {
489 56         228 my $start_of_century_year = int($self->{_dt}->year / 100) * 100;
490 56         495 $year = $start_of_century_year + $y0;
491             } else {
492 23         60 $year = $y0;
493             }
494 79         339 $self->{_dt}->set_year($year);
495             }
496 147 50       58207 if (defined $m->{o_dayint}) {
497 147         629 $self->{_dt}->set_day($m->{o_dayint});
498             }
499 147 100       97834 if (defined $m->{o_monthint}) {
500 92         411 $self->{_dt}->set_month($m->{o_monthint});
501             }
502 147 100       66081 if (defined $m->{o_monthname}) {
503 4     4   3806 no strict 'refs';
  4         14  
  4         765  
504 61         130 my $maps = ${ ref($self) . '::MAPS' };
  61         422  
505 61         398 $self->{_dt}->set_month($maps->{months}{lc $m->{o_monthname}});
506             }
507             }
508              
509             sub a_dateym {
510 4     4 0 14 my ($self, $m) = @_;
511 4         12 $m->{o_dayint} = 1;
512 4         18 $self->a_dateymd($m);
513 4         2221 delete $m->{o_dayint};
514             }
515              
516             sub a_which_dow {
517 4     4   43 no strict 'refs';
  4         15  
  4         2204  
518              
519 27     27 0 81 my ($self, $m) = @_;
520 27         122 $self->a_today;
521 27         125 my $dow_num = $self->{_dt}->day_of_week;
522              
523 27         130 my $maps = ${ ref($self) . '::MAPS' };
  27         166  
524 27         105 my $wanted_dow_num = $maps->{dow}{lc $m->{o_dow} };
525              
526 27         142 $self->{_dt}->add(days => ($wanted_dow_num-$dow_num));
527              
528 27 100       28619 if ($m->{offset}) {
529 12         59 $self->{_dt}->add(days => (7*$m->{offset}));
530             }
531             }
532              
533             sub adur_dur {
534 24     24 0 61 my ($self, $m) = @_;
535 24         81 $self->{_dtdur} = $self->_parse_dur($m->{odur_dur});
536             }
537              
538             sub a_dur_ago {
539 3     3 0 13 my ($self, $m) = @_;
540 3         19 $self->a_now;
541 3         13 my $dur = $self->_parse_dur($m->{o_dur});
542 3         426 $self->{_dt}->subtract_duration($dur);
543             }
544              
545             sub a_dur_later {
546 3     3 0 11 my ($self, $m) = @_;
547 3         16 $self->a_now;
548 3         17 my $dur = $self->_parse_dur($m->{o_dur});
549 3         395 $self->{_dt}->add_duration($dur);
550             }
551              
552             sub a_time {
553 14     14 0 71 my ($self, $m) = @_;
554 14         79 $self->_now_if_unset;
555 14         100 $self->{_uses_time} = 1;
556 14         50 my $hour = $m->{o_hour};
557 14 100       64 if ($m->{o_ampm}) {
558 3 100 66     30 $hour += 12 if lc($m->{o_ampm}) eq 'pm' && $hour < 12;
559 3 50 66     23 $hour = 0 if lc($m->{o_ampm}) eq 'am' && $hour == 12;
560             }
561 14         79 $self->{_dt}->set_hour($hour);
562 14         9240 $self->{_dt}->set_minute($m->{o_minute});
563 14   100     9628 $self->{_dt}->set_second($m->{o_second} // 0);
564             }
565              
566             sub a_date_time {
567 8     8 0 384 my ($self, $m) = @_;
568             }
569              
570             1;
571             # ABSTRACT: Parse human date/time expression (base class)
572              
573             __END__
574              
575             =pod
576              
577             =encoding UTF-8
578              
579             =head1 NAME
580              
581             DateTime::Format::Alami - Parse human date/time expression (base class)
582              
583             =head1 VERSION
584              
585             This document describes version 0.16 of DateTime::Format::Alami (from Perl distribution DateTime-Format-Alami), released on 2017-07-10.
586              
587             =head1 SYNOPSIS
588              
589             For English:
590              
591             use DateTime::Format::Alami::EN;
592             my $parser = DateTime::Format::Alami::EN->new();
593             my $dt = $parser->parse_datetime("2 hours 13 minutes from now");
594              
595             Or you can also call as class method:
596              
597             my $dt = DateTime::Format::Alami::EN->parse_datetime("yesterday");
598              
599             To parse duration:
600              
601             my $dtdur = DateTime::Format::Alami::EN->parse_datetime_duration("2h"); # 2 hours
602              
603             For Indonesian:
604              
605             use DateTime::Format::Alami::ID;
606             my $parser = DateTime::Format::Alami::ID->new();
607             my $dt = $parser->parse_datetime("5 jam lagi");
608              
609             Or you can also call as class method:
610              
611             my $dt = DateTime::Format::Alami::ID->parse_datetime("hari ini");
612              
613             To parse duration:
614              
615             my $dtdur = DateTime::Format::Alami::ID->parse_datetime_duration("2h"); # 2 days
616              
617             =head1 DESCRIPTION
618              
619             This class parses human/natural date/time/duration string and returns
620             L<DateTime> (or L<DateTime::Duration>) object. Currently it supports English and
621             Indonesian. The goal of this module is to make it easier to add support for
622             other human languages.
623              
624             To actually use this class, you must use one of its subclasses for each
625             human language that you want to parse.
626              
627             There are already some other DateTime human language parsers on CPAN and
628             elsewhere, see L</"SEE ALSO">.
629              
630             =for Pod::Coverage ^((adur|a|pdur|p|odur|o|w)_.+)$
631              
632             =head1 HOW IT WORKS
633              
634             L<DateTime::Format::Alami> is base class. Each human language is implemented in
635             a separate C<< DateTime::Format::Alami::<ISO_CODE> >> module (e.g.
636             L<DateTime::Format::Alami::EN> and L<DateTime::Format::Alami::EN>) which is a
637             subclass.
638              
639             Parsing is done using a single recursive regex (i.e. containing C<(?&NAME)> and
640             C<(?(DEFINE))> patterns, see L<perlre>). This regex is composed from pieces of
641             pattern strings in the C<p_*> and C<o_*> methods, to make it easier to override
642             in an OO-fashion.
643              
644             A pattern string that is returned by the C<p_*> method is a normal regex pattern
645             string that will be compiled using the /x and /i regex modifier. The pattern
646             string can also refer to pattern in other C<o_*> or C<p_*> method using syntax
647             C<< <o_foo> >> or C<< <p_foo> >>. Example, C<o_today> for English might be
648             something like:
649              
650             sub p_today { "(?: today | this \s+ day )" }
651              
652             Other examples:
653              
654             sub p_yesterday { "(?: yesterday )" }
655              
656             sub p_dateymd { join(
657             "",
658             '(?: <o_dayint> \\s* ?<o_monthname> | <o_monthname> \\s* <o_dayint>\\b|<o_monthint>[ /-]<o_dayint>\\b )',
659             '(?: \\s*[,/-]?\\s* <o_yearint>)?'
660             )}
661              
662             sub o_date { "(?: <p_today>|<p_yesterday>|<p_dateymd>)" }
663              
664             sub p_time { "(?: <o_hour>:<o_minute>(?:<o_second>)? \s* <o_ampm> )" }
665              
666             sub p_date_time { "(?: <o_date> (?:\s+ at)? <o_time> )" }
667              
668             When a pattern from C<p_*> matches, a corresponding action method C<a_*> will be
669             invoked. Usually the method will set or modify a DateTime object in C<<
670             $self->{_dt} >>. For example, this is code for C<a_today>:
671              
672             sub a_today {
673             my $self = shift;
674             $self->{_dt} = DateTime->today;
675             }
676              
677             The patterns from all C<p_*> methods will be combined in an alternation to form
678             the final pattern.
679              
680             An C<o_*> pattern is just like C<p_*>, but they will not be
681             combined into the final pattern and matching it won't execute a corresponding
682             C<a_*> method.
683              
684             And there are also C<w_*> methods which return array of strings.
685              
686             Parsing duration is similar, except the method names are C<pdur_*>, C<odur_*>
687             and C<adur_*>.
688              
689             =head1 ADDING A NEW HUMAN LANGUAGE
690              
691             See an example in existing C<DateTime::Format::Alami::*> module. Basically you
692             just need to supply the necessary patterns in the C<p_*> methods. If you want to
693             introduce new C<p_*> method, don't forget to supply the action too in the C<a_*>
694             method.
695              
696             =head1 METHODS
697              
698             =head2 new => obj
699              
700             Constructor. You actually must instantiate subclass instead.
701              
702             =head2 parse_datetime($str[ , \%opts ]) => obj
703              
704             Parse/extract date/time expression in C<$str>. Die if expression cannot be
705             parsed. Otherwise return L<DateTime> object (or string/number if C<format>
706             option is C<verbatim>/C<epoch>, or hash if C<format> option is C<combined>) or
707             array of objects/strings/numbers (if C<returns> option is C<all>/C<all_cron>).
708              
709             Known options:
710              
711             =over
712              
713             =item * time_zone => str
714              
715             Will be passed to DateTime constructor.
716              
717             =item * format => str (DateTime|verbatim|epoch|combined)
718              
719             The default is C<DateTime>, which will return DateTime object. Other choices
720             include C<verbatim> (returns the original text), C<epoch> (returns Unix
721             timestamp), C<combined> (returns a hash containing keys like C<DateTime>,
722             C<verbatim>, C<epoch>, and other extra information: C<pos> [position of pattern
723             in the string], C<pattern> [pattern name], C<m> [raw named capture groups],
724             C<uses_time> [whether the date involves time of day]).
725              
726             You might think that choosing C<epoch> or C<verbatim> could avoid the overhead
727             of DateTime, but actually you can't since DateTime is used as the primary format
728             during parsing. The epoch is retrieved from the DateTime object using the
729             C<epoch> method.
730              
731             =item * prefers => str (nearest|future|past)
732              
733             NOT YET IMPLEMENTED.
734              
735             This option decides what happens when an ambiguous date appears in the input.
736             For example, "Friday" may refer to any number of Fridays. Possible choices are:
737             C<nearest> (prefer the nearest date, the default), C<future> (prefer the closest
738             future date), C<past> (prefer the closest past date).
739              
740             =item * returns => str (first|last|earliest|latest|all|all_cron)
741              
742             If the text has multiple possible dates, then this argument determines which
743             date will be returned. Possible choices are: C<first> (return the first date
744             found in the string, the default), C<last> (return the final date found in the
745             string), C<earliest> (return the date found in the string that chronologically
746             precedes any other date in the string), C<latest> (return the date found in the
747             string that chronologically follows any other date in the string), C<all>
748             (return all dates found in the string, in the order they were found in the
749             string), C<all_cron> (return all dates found in the string, in chronological
750             order).
751              
752             When C<all> or C<all_cron> is chosen, function will return array(ref) of results
753             instead of a single result, even if there is only a single actual result.
754              
755             =back
756              
757             =head2 parse_datetime_duration($str[ , \%opts ]) => obj
758              
759             Parse/extract duration expression in C<$str>. Die if expression cannot be
760             parsed. Otherwise return L<DateTime::Duration> object (or string/number if
761             C<format> option is C<verbatim>/C<seconds>, or hash if C<format> option is
762             C<combined>) or array of objects/strings/numbers (if C<returns> option is
763             C<all>/C<all_sorted>).
764              
765             Known options:
766              
767             =over
768              
769             =item * format => str (Duration|verbatim|seconds|combined)
770              
771             The default is C<Duration>, which will return DateTime::Duration object. Other
772             choices include C<verbatim> (returns the original text), C<seconds> (returns
773             number of seconds, approximated), C<combined> (returns a hash containing keys
774             like C<Duration>, C<verbatim>, C<seconds>, and other extra information: C<pos>
775             [position of pattern in the string], C<pattern> [pattern name], C<m> [raw named
776             capture groups]).
777              
778             You might think that choosing C<seconds> or C<verbatim> could avoid the overhead
779             of DateTime::Duration, but actually you can't since DateTime::Duration is used
780             as the primary format during parsing. The number of seconds is calculated from
781             the DateTime::Duration object I<using an approximation> (for example, "1 month"
782             does not convert exactly to seconds).
783              
784             =item * returns => str (first|last|smallest|largest|all|all_sorted)
785              
786             If the text has multiple possible durations, then this argument determines which
787             date will be returned. Possible choices are: C<first> (return the first duration
788             found in the string, the default), C<last> (return the final duration found in
789             the string), C<smallest> (return the smallest duration), C<largest> (return the
790             largest duration), C<all> (return all durations found in the string, in the
791             order they were found in the string), C<all_sorted> (return all durations found
792             in the string, in smallest-to-largest order).
793              
794             When C<all> or C<all_sorted> is chosen, function will return array(ref) of
795             results instead of a single result, even if there is only a single actual
796             result.
797              
798             =back
799              
800             =head1 FAQ
801              
802             =head2 What does "alami" mean?
803              
804             It is an Indonesian word, meaning "natural".
805              
806             =head2 How does it compare to similar modules?
807              
808             L<DateTime::Format::Natural> (DF:Natural) is a more established module (first
809             released on 2006) and can understand a bit more English expression like 'last
810             day of Sep'. Aside from English, it does not yet support other languages.
811              
812             DFA:EN's C<parse_datetime_duration()> produces a L<DateTime::Duration> object
813             while DF:Natural's C<parse_datetime_duration()> returns two L<DateTime> objects
814             instead. In other words, DF:Natural can parse "from 23 Jun to 29 Jun" in
815             addition to "for 2 weeks".
816              
817             DF:Natural in general is slightly more strict about the formats it accepts, e.g.
818             it rejects C<Jun 23st> (the error message even gives hints that the suffix must
819             be 'rd'). DF:Natural can give a detailed error message on why parsing has failed
820             (see its C<error()> method).
821              
822             L<DateTime::Format::Flexible> (DF:Flexible) is another established module (first
823             released in 2007) that, aside from parsing human expression (like 'tomorrow',
824             'sep 1st') can also parse date/time in several other formats like RFC 822,
825             making it a convenient module to use as a 'one-stop' solution to parse date.
826             Compared to DF:Natural, it has better support for timezone but cannot parse some
827             English expressions. Aside from English, it currently supports German and
828             Spanish. It does not support parsing duration expression.
829              
830             This module itself: B<DateTime::Format::Alami> (DF:Alami) is yet another
831             implementation. Internally, it uses recursive regex to make parsing simpler and
832             adding more languages easier. It requires perl 5.14.0 or newer due to the use of
833             C<(?{ ... })> code blocks inside regular expression (while DF:Natural and
834             DF:Flexible can run on perl 5.8+). It currently supports English and Indonesian.
835             It supports parsing duration expression and returns DateTime::Duration object.
836             It has the smallest startup time (see see
837             L<Bencher::Scenario::DateTimeFormatAlami::Startup>).
838              
839             Performance-wise, all the modules are within the same order of magnitude (see
840             L<Bencher::Scenario::DateTimeFormatAlami::Parsing>).
841              
842             =head1 HOMEPAGE
843              
844             Please visit the project's homepage at L<https://metacpan.org/release/DateTime-Format-Alami>.
845              
846             =head1 SOURCE
847              
848             Source repository is at L<https://github.com/perlancar/perl-DateTime-Format-Alami>.
849              
850             =head1 BUGS
851              
852             Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=DateTime-Format-Alami>
853              
854             When submitting a bug or request, please include a test-file or a
855             patch to an existing test-file that illustrates the bug or desired
856             feature.
857              
858             =head1 SEE ALSO
859              
860             =head2 Similar modules on CPAN
861              
862             L<Date::Extract>. DateTime::Format::Alami has some features of Date::Extract so
863             it can be used to replace Date::Extract.
864              
865             L<DateTime::Format::Flexible>. See L</"FAQ">.
866              
867             For Indonesian: L<DateTime::Format::Indonesian>, L<Date::Extract::ID> (currently
868             this module uses DateTime::Format::Alami::ID as its backend).
869              
870             For English: L<DateTime::Format::Natural>. See L</"FAQ">.
871              
872             =head2 Other modules on CPAN
873              
874             L<DateTime::Format::Human> deals with formatting and not parsing.
875              
876             =head2 Similar non-Perl libraries
877              
878             Natt Java library, which the last time I tried sometimes gives weird answer,
879             e.g. "32 Oct" becomes 1 Oct in the far future. http://natty.joestelmach.com/
880              
881             Duckling Clojure library, which can parse date/time as well as numbers with some
882             other units like temperature. https://github.com/wit-ai/duckling
883              
884             =head1 AUTHOR
885              
886             perlancar <perlancar@cpan.org>
887              
888             =head1 COPYRIGHT AND LICENSE
889              
890             This software is copyright (c) 2017, 2016, 2014 by perlancar@cpan.org.
891              
892             This is free software; you can redistribute it and/or modify it under
893             the same terms as the Perl 5 programming language system itself.
894              
895             =cut