File Coverage

blib/lib/Date/Extract.pm
Criterion Covered Total %
statement 104 104 100.0
branch 24 26 92.3
condition 42 57 73.6
subroutine 22 22 100.0
pod 2 2 100.0
total 194 211 91.9


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__