line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Date::Extract; |
2
|
7
|
|
|
7
|
|
164533
|
use strict; |
|
7
|
|
|
|
|
21
|
|
|
7
|
|
|
|
|
284
|
|
3
|
7
|
|
|
7
|
|
156
|
use warnings; |
|
7
|
|
|
|
|
15
|
|
|
7
|
|
|
|
|
216
|
|
4
|
7
|
|
|
7
|
|
7820
|
use DateTime::Format::Natural; |
|
7
|
|
|
|
|
2264885
|
|
|
7
|
|
|
|
|
645
|
|
5
|
7
|
|
|
7
|
|
96
|
use List::Util 'reduce'; |
|
7
|
|
|
|
|
45
|
|
|
7
|
|
|
|
|
810
|
|
6
|
7
|
|
|
7
|
|
45
|
use parent 'Class::Data::Inheritable'; |
|
7
|
|
|
|
|
15
|
|
|
7
|
|
|
|
|
71
|
|
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
our $VERSION = '0.05'; |
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
__PACKAGE__->mk_classdata($_) for qw/scalar_downgrade handlers regex/; |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
sub _croak { |
13
|
3
|
|
|
3
|
|
28
|
require Carp; |
14
|
3
|
|
|
|
|
666
|
Carp::croak @_; |
15
|
|
|
|
|
|
|
} |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
sub new { |
18
|
41
|
|
|
41
|
1
|
60904
|
my $class = shift; |
19
|
41
|
|
|
|
|
289
|
my %args = ( |
20
|
|
|
|
|
|
|
format => 'DateTime', |
21
|
|
|
|
|
|
|
returns => 'first', |
22
|
|
|
|
|
|
|
prefers => 'nearest', |
23
|
|
|
|
|
|
|
time_zone => 'floating', |
24
|
|
|
|
|
|
|
@_, |
25
|
|
|
|
|
|
|
); |
26
|
|
|
|
|
|
|
|
27
|
41
|
100
|
100
|
|
|
224
|
if ($args{format} ne 'DateTime' |
|
|
|
100
|
|
|
|
|
28
|
|
|
|
|
|
|
&& $args{format} ne 'verbatim' |
29
|
|
|
|
|
|
|
&& $args{format} ne 'epoch') { |
30
|
1
|
|
|
|
|
4
|
_croak "Invalid `format` passed to constructor: expected `DateTime', `verbatim', `epoch'."; |
31
|
|
|
|
|
|
|
} |
32
|
|
|
|
|
|
|
|
33
|
40
|
100
|
100
|
|
|
228
|
if ($args{returns} ne 'first' |
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
34
|
|
|
|
|
|
|
&& $args{returns} ne 'last' |
35
|
|
|
|
|
|
|
&& $args{returns} ne 'earliest' |
36
|
|
|
|
|
|
|
&& $args{returns} ne 'latest' |
37
|
|
|
|
|
|
|
&& $args{returns} ne 'all' |
38
|
|
|
|
|
|
|
&& $args{returns} ne 'all_cron') { |
39
|
1
|
|
|
|
|
5
|
_croak "Invalid `returns` passed to constructor: expected `first', `last', `earliest', `latest', `all', or `all_cron'."; |
40
|
|
|
|
|
|
|
} |
41
|
|
|
|
|
|
|
|
42
|
39
|
100
|
66
|
|
|
144
|
if ($args{prefers} ne 'nearest' |
|
|
|
100
|
|
|
|
|
43
|
|
|
|
|
|
|
&& $args{prefers} ne 'past' |
44
|
|
|
|
|
|
|
&& $args{prefers} ne 'future') { |
45
|
1
|
|
|
|
|
6
|
_croak "Invalid `prefers` passed to constructor: expected `nearest', `past', or `future'."; |
46
|
|
|
|
|
|
|
} |
47
|
|
|
|
|
|
|
|
48
|
38
|
|
33
|
|
|
235
|
my $self = bless \%args, ref($class) || $class; |
49
|
|
|
|
|
|
|
|
50
|
38
|
|
|
|
|
101
|
return $self; |
51
|
|
|
|
|
|
|
} |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
# This method will combine the arguments of parser->new and extract. Modify the |
54
|
|
|
|
|
|
|
# "to" hash directly. |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
sub _combine_args { |
57
|
57
|
|
|
57
|
|
84
|
shift; |
58
|
|
|
|
|
|
|
|
59
|
57
|
|
|
|
|
87
|
my $from = shift; |
60
|
57
|
|
|
|
|
85
|
my $to = shift; |
61
|
|
|
|
|
|
|
|
62
|
57
|
|
33
|
|
|
396
|
$to->{format} ||= $from->{format}; |
63
|
57
|
|
33
|
|
|
267
|
$to->{prefers} ||= $from->{prefers}; |
64
|
57
|
|
66
|
|
|
230
|
$to->{returns} ||= $from->{returns}; |
65
|
57
|
|
33
|
|
|
365
|
$to->{time_zone} ||= $from->{time_zone}; |
66
|
|
|
|
|
|
|
} |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
sub extract { |
69
|
57
|
|
|
57
|
1
|
71225
|
my $self = shift; |
70
|
57
|
|
|
|
|
113
|
my $text = shift; |
71
|
57
|
|
|
|
|
168
|
my %args = @_; |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
# using extract as a class method |
74
|
57
|
100
|
|
|
|
266
|
$self = $self->new |
75
|
|
|
|
|
|
|
if !ref($self); |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
# combine the arguments of parser->new and this |
78
|
57
|
|
|
|
|
217
|
$self->_combine_args($self, \%args); |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
# when in scalar context, downgrade |
81
|
57
|
100
|
|
|
|
271
|
$args{returns} = $self->_downgrade($args{returns}) |
82
|
|
|
|
|
|
|
unless wantarray; |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
# do the work |
85
|
57
|
|
|
|
|
251
|
my @ret = $self->_extract($text, %args); |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
# munge the output to match the desired return type |
88
|
57
|
|
|
|
|
420
|
return $self->_handle($args{returns}, @ret); |
89
|
|
|
|
|
|
|
} |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
# build the giant regex used for parsing. it has to be a single regex, so that |
92
|
|
|
|
|
|
|
# the order of matches is correct. |
93
|
|
|
|
|
|
|
sub _build_regex { |
94
|
5
|
|
|
5
|
|
62
|
my $self = shift; |
95
|
|
|
|
|
|
|
|
96
|
5
|
|
|
|
|
12
|
my $relative = '(?:today|tomorrow|yesterday)'; |
97
|
|
|
|
|
|
|
|
98
|
5
|
|
|
|
|
10
|
my $long_weekday = '(?:Monday|Tuesday|Wednesday|Thursday|Friday|Saturday|Sunday)'; |
99
|
5
|
|
|
|
|
11
|
my $short_weekday = '(?:Mon|Tue|Wed|Thu|Fri|Sat|Sun)'; |
100
|
5
|
|
|
|
|
22
|
my $weekday = "(?:$long_weekday|$short_weekday)"; |
101
|
|
|
|
|
|
|
|
102
|
5
|
|
|
|
|
24
|
my $relative_weekday = "(?:(?:next|previous|last)\\s*$weekday)"; |
103
|
|
|
|
|
|
|
|
104
|
5
|
|
|
|
|
12
|
my $long_month = '(?:January|February|March|April|May|June|July|August|September|October|November|December)'; |
105
|
5
|
|
|
|
|
9
|
my $short_month = '(?:Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec)'; |
106
|
5
|
|
|
|
|
19
|
my $month = "(?:$long_month|$short_month)"; |
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
# 1 - 31 |
109
|
5
|
|
|
|
|
17
|
my $cardinal_monthday = "(?:[1-9]|[12][0-9]|3[01])"; |
110
|
5
|
|
|
|
|
117
|
my $monthday = "(?:$cardinal_monthday(?:st|nd|rd|th)?)"; |
111
|
|
|
|
|
|
|
|
112
|
5
|
|
|
|
|
22
|
my $day_month = "(?:$monthday\\s*$month)"; |
113
|
5
|
|
|
|
|
18
|
my $month_day = "(?:$month\\s*$monthday)"; |
114
|
5
|
|
|
|
|
26
|
my $day_month_year = "(?:(?:$day_month|$month_day)\\s*,?\\s*\\d\\d\\d\\d)"; |
115
|
|
|
|
|
|
|
|
116
|
5
|
|
|
|
|
11
|
my $yyyymmdd = "(?:\\d\\d\\d\\d[-/]\\d\\d[-/]\\d\\d)"; |
117
|
5
|
|
|
|
|
11
|
my $ddmmyy = "(?:\\d\\d[-/]\\d\\d[-/]\\d\\d)"; |
118
|
5
|
|
|
|
|
10
|
my $ddmmyyyy = "(?:\\d\\d[-/]\\d\\d[-/]\\d\\d\\d\\d)"; |
119
|
|
|
|
|
|
|
|
120
|
5
|
|
|
|
|
28
|
my $other = $self->_build_more_regex; |
121
|
5
|
50
|
|
|
|
34
|
$other = "|$other" |
122
|
|
|
|
|
|
|
if $other; |
123
|
|
|
|
|
|
|
|
124
|
5
|
|
|
|
|
3612
|
my $regex = qr{ |
125
|
|
|
|
|
|
|
\b( |
126
|
|
|
|
|
|
|
$relative # today |
127
|
|
|
|
|
|
|
| $relative_weekday # last Friday |
128
|
|
|
|
|
|
|
| $weekday # Monday |
129
|
|
|
|
|
|
|
| $day_month_year # November 13th, 1986 |
130
|
|
|
|
|
|
|
| $day_month # November 13th |
131
|
|
|
|
|
|
|
| $month_day # 13 Nov |
132
|
|
|
|
|
|
|
| $yyyymmdd # 1986/11/13 |
133
|
|
|
|
|
|
|
| $ddmmyy # 11-13-86 |
134
|
|
|
|
|
|
|
| $ddmmyyyy # 11-13-1986 |
135
|
|
|
|
|
|
|
$other # anything from the subclass |
136
|
|
|
|
|
|
|
)\b |
137
|
|
|
|
|
|
|
}ix; |
138
|
|
|
|
|
|
|
|
139
|
5
|
|
|
|
|
39
|
$self->regex($regex); |
140
|
|
|
|
|
|
|
} |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
# this is to be used in subclasses for adding more stuff to the regex |
143
|
|
|
|
|
|
|
# for example, to add support for $foo_bar and $baz_quux, return |
144
|
|
|
|
|
|
|
# "$foo_bar|$baz_quux" |
145
|
5
|
|
|
5
|
|
12
|
sub _build_more_regex { '' } |
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
# build the list->scalar downgrade types |
148
|
|
|
|
|
|
|
sub _build_scalar_downgrade { |
149
|
5
|
|
|
5
|
|
139
|
my $self = shift; |
150
|
|
|
|
|
|
|
|
151
|
5
|
|
|
|
|
36
|
$self->scalar_downgrade({ |
152
|
|
|
|
|
|
|
all => 'first', |
153
|
|
|
|
|
|
|
all_cron => 'earliest', |
154
|
|
|
|
|
|
|
}); |
155
|
|
|
|
|
|
|
} |
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
# build the handlers that munge the list of dates to the desired order |
158
|
|
|
|
|
|
|
sub _build_handlers { |
159
|
5
|
|
|
5
|
|
82
|
my $self = shift; |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
$self->handlers({ |
162
|
|
|
|
|
|
|
all_cron => sub { |
163
|
1
|
|
|
1
|
|
8
|
sort { DateTime->compare_ignore_floating($a, $b) } @_ |
|
2
|
|
|
|
|
72
|
|
164
|
|
|
|
|
|
|
}, |
165
|
1
|
|
|
1
|
|
8
|
all => sub { @_ }, |
166
|
|
|
|
|
|
|
|
167
|
2
|
100
|
|
2
|
|
31
|
earliest => sub { reduce { $a < $b ? $a : $b } @_ }, |
|
4
|
|
|
|
|
177
|
|
168
|
1
|
100
|
|
1
|
|
12
|
latest => sub { reduce { $a > $b ? $a : $b } @_ }, |
|
2
|
|
|
|
|
84
|
|
169
|
51
|
|
|
51
|
|
429
|
first => sub { $_[0] }, |
170
|
1
|
|
|
1
|
|
16
|
last => sub { $_[-1] }, |
171
|
5
|
|
|
|
|
111
|
}); |
172
|
|
|
|
|
|
|
} |
173
|
|
|
|
|
|
|
|
174
|
|
|
|
|
|
|
# actually perform the scalar downgrade |
175
|
|
|
|
|
|
|
sub _downgrade { |
176
|
51
|
|
|
51
|
|
84
|
my $self = shift; |
177
|
51
|
|
|
|
|
63
|
my $returns = shift; |
178
|
|
|
|
|
|
|
|
179
|
51
|
|
66
|
|
|
217
|
my $downgrades = $self->scalar_downgrade || $self->_build_scalar_downgrade; |
180
|
51
|
|
66
|
|
|
628
|
return $downgrades->{$returns} || $returns; |
181
|
|
|
|
|
|
|
} |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
sub _handle { |
184
|
57
|
|
|
57
|
|
112
|
my $self = shift; |
185
|
57
|
|
|
|
|
116
|
my $returns = shift; |
186
|
|
|
|
|
|
|
|
187
|
57
|
|
66
|
|
|
350
|
my $handlers = $self->handlers || $self->_build_handlers; |
188
|
57
|
|
|
|
|
631
|
my $handler = $handlers->{$returns}; |
189
|
57
|
50
|
|
|
|
329
|
return defined $handler ? $handler->(@_) : @_ |
190
|
|
|
|
|
|
|
} |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
sub _extract { |
193
|
57
|
|
|
57
|
|
80
|
my $self = shift; |
194
|
57
|
|
|
|
|
78
|
my $text = shift; |
195
|
57
|
|
|
|
|
185
|
my %args = @_; |
196
|
|
|
|
|
|
|
|
197
|
57
|
|
66
|
|
|
213
|
my $regex = $self->regex || $self->_build_regex; |
198
|
57
|
|
|
|
|
1679
|
my @gleaned = $text =~ /$regex/g; |
199
|
|
|
|
|
|
|
|
200
|
57
|
100
|
|
|
|
222
|
return @gleaned if $self->{format} eq 'verbatim'; |
201
|
|
|
|
|
|
|
|
202
|
56
|
|
|
|
|
84
|
my %dtfn_args; |
203
|
56
|
100
|
66
|
|
|
345
|
$dtfn_args{prefer_future} = 1 |
204
|
|
|
|
|
|
|
if $args{prefers} && $args{prefers} eq 'future'; |
205
|
56
|
|
|
|
|
212
|
$dtfn_args{time_zone} = $args{time_zone}; |
206
|
|
|
|
|
|
|
|
207
|
56
|
|
|
|
|
370
|
my $parser = DateTime::Format::Natural->new(%dtfn_args); |
208
|
56
|
|
|
|
|
233550
|
my @ret; |
209
|
56
|
|
|
|
|
138
|
for (@gleaned) { |
210
|
78
|
|
|
|
|
1206
|
my $dt = $parser->parse_datetime($_); |
211
|
78
|
100
|
|
|
|
471506
|
push @ret, $dt->set_time_zone($args{time_zone}) |
212
|
|
|
|
|
|
|
if $parser->success; |
213
|
|
|
|
|
|
|
} |
214
|
|
|
|
|
|
|
|
215
|
56
|
100
|
|
|
|
2677
|
if ($self->{format} eq 'epoch') { |
216
|
1
|
|
|
|
|
4
|
return map { $_->epoch } @ret; |
|
3
|
|
|
|
|
28
|
|
217
|
|
|
|
|
|
|
} |
218
|
55
|
|
|
|
|
2569
|
return @ret; |
219
|
|
|
|
|
|
|
} |
220
|
|
|
|
|
|
|
|
221
|
|
|
|
|
|
|
1; |
222
|
|
|
|
|
|
|
|
223
|
|
|
|
|
|
|
__END__ |