File Coverage

blib/lib/Time/Strptime/Format.pm
Criterion Covered Total %
statement 139 144 96.5
branch 48 60 80.0
condition 26 40 65.0
subroutine 23 23 100.0
pod 2 2 100.0
total 238 269 88.4


line stmt bran cond sub pod time code
1             package Time::Strptime::Format;
2 4     4   51969 use strict;
  4         10  
  4         110  
3 4     4   19 use warnings;
  4         7  
  4         88  
4 4     4   2209 use utf8;
  4         54  
  4         17  
5 4     4   1693 use integer;
  4         47  
  4         22  
6              
7 4     4   109 use B;
  4         8  
  4         138  
8 4     4   17 use Carp ();
  4         8  
  4         63  
9 4     4   1624 use Time::Local qw/timegm timegm_nocheck/;
  4         5038  
  4         215  
10 4     4   1813 use Encode qw/encode_utf8/;
  4         30199  
  4         253  
11 4     4   1611 use DateTime::Locale;
  4         681638  
  4         143  
12 4     4   2196 use List::MoreUtils qw/uniq/;
  4         26428  
  4         39  
13 4     4   4403 use POSIX qw/strftime LC_ALL/;
  4         18406  
  4         24  
14 4     4   6179 use Time::Strptime::TimeZone;
  4         24  
  4         166  
15              
16 4   33 4   24 use constant DEBUG => exists $ENV{PERL_TIME_STRPTIME_DEBUG} && $ENV{PERL_TIME_STRPTIME_DEBUG};
  4         8  
  4         6519  
17              
18             our $VERSION = 1.01;
19              
20             our %DEFAULT_HANDLER = (
21             A => [SKIP => sub {
22             my $self = shift;
23             my $wide = $self->{locale}->day_format_wide;
24             my $abbr = $self->{locale}->day_format_abbreviated;
25             return [map quotemeta, uniq map { lc, uc, $_ } map { $wide->[$_], $abbr->[$_] } 0..6];
26             }],
27             a => [extend => q{%A} ],
28             B => [localed_month => sub {
29             my $self = shift;
30              
31             unless (exists $self->{format_table}{localed_month}) {
32             my %format_table;
33              
34             my $wide = $self->{locale}->month_format_wide;
35             my $abbr = $self->{locale}->month_format_abbreviated;
36             for my $month (0..11) {
37             for my $key ($wide->[$month], $abbr->[$month]) {
38             $format_table{$key} = $month + 1;
39             $format_table{lc $key} = $month + 1;
40             $format_table{uc $key} = $month + 1;
41             }
42             }
43             $self->{format_table}{localed_month} = \%format_table;
44             }
45              
46             return [map quotemeta, keys %{ $self->{format_table}{localed_month} }];
47             } ],
48             b => [extend => q{%B}],
49             C => ['UNSUPPORTED'],
50             c => ['UNSUPPORTED'],
51             D => [extend => q{%m/%d/%Y} ],
52             d => [day => ['0[1-9]','[12][0-9]','3[01]'] ],
53             e => [day => [' [1-9]','[12][0-9]','3[01]'] ],
54             F => [extend => q{%Y-%m-%d} ],
55             G => ['UNSUPPORTED'],
56             g => ['UNSUPPORTED'],
57             H => [hour24 => ['[01][0-9]','2[0-3]'] ],
58             h => [extend => q{%B} ],
59             I => [hour12 => ['0[1-9]', '1[0-2]'] ],
60             j => [day365 => ['00[1-9]', '0[1-9][0-9]', '[12][0-9][0-9]','3[0-5][0-9]','36[0-6]'] ],
61             k => [hour24 => ['[ 1][0-9]','2[0-3]'] ],
62             l => [hour12 => [' [1-9]', '1[0-2]'] ],
63             M => [minute => q{[0-5][0-9]} ],
64             m => [month => ['0[1-9]','1[0-2]'] ],
65             n => [SKIP => q{\s+} ],
66             p => [localed_pm => sub {
67             my $self = shift;
68             unless (exists $self->{format_table}{localed_pm}) {
69             for my $pm (0, 1) {
70             my $key = $self->{locale}->am_pm_abbreviated->[$pm];
71             $self->{format_table}{localed_pm}{$key} = $pm;
72             }
73             }
74             return [map quotemeta, keys %{ $self->{format_table}{localed_pm} }];
75             }],
76             R => [extend => q{%H:%M} ],
77             r => [extend => q{%I:%M:%S %p} ],
78             S => [second => ['[0-5][0-9]','60'] ],
79             s => [epoch => q{[0-9]+} ],
80             T => [extend => q{%H:%M:%S} ],
81             t => [char => "\t" ],
82             U => ['UNSUPPORTED'],
83             u => ['UNSUPPORTED'],
84             V => ['UNSUPPORTED'],
85             v => [extend => q{%e-%b-%Y} ],
86             W => ['UNSUPPORTED'],
87             w => ['UNSUPPORTED'],
88             X => ['UNSUPPORTED'],
89             x => ['UNSUPPORTED'],
90             Y => [year => q{[0-9]{4}}],
91             y => ['UNSUPPORTED'],
92             Z => [timezone => ['[-A-Z0-9]+', '[A-Z][a-z]+(?:/[A-Z][a-z]+)+']],
93             z => [offset => q{[-+][0-9]{4}}],
94             );
95              
96             our %FIXED_OFFSET = (
97             GMT => 0,
98             UTC => 0,
99             Z => 0,
100             );
101              
102             sub new {
103 23     23 1 39898 my ($class, $format, $options) = @_;
104 23   100     88 $options ||= +{};
105              
106             my $self = bless +{
107             format => $format,
108             time_zone => Time::Strptime::TimeZone->new($options->{time_zone}),
109             locale => DateTime::Locale->load($options->{locale} || 'C'),
110             strict => $options->{strict} || 0,
111             _handler => +{
112             %DEFAULT_HANDLER,
113 23 50 100     120 %{ $options->{handler} || {} },
  23   50     4777  
114             },
115             } => $class;
116              
117             # compile and cache
118 23         107 $self->_parser();
119              
120 23         71 return $self;
121             }
122              
123             sub parse {
124 23     23 1 43 my $self = shift;
125 23         47 goto $self->_parser;
126             }
127              
128             sub _parser {
129 46     46   77 my $self = shift;
130 46   66     573 return $self->{_parser} ||= $self->_compile_format;
131             }
132              
133             sub _compile_format {
134 23     23   35 my $self = shift;
135 23         45 my $format = $self->{format};
136              
137 23         43 my $parser = do {
138             # setlocale
139 23         33 my $time_zone = $self->{time_zone};
140              
141             # assemble format to regexp
142 23         39 my $handlers = join '', keys %{ $self->{_handler} };
  23         156  
143 23         60 my @types;
144 23         257 $format =~ s{([^%]*)?%([${handlers}])([^%]*)?}{
145 95   100     392 my $prefix = quotemeta($1||'');
146 95   100     272 my $suffix = quotemeta($3||'');
147 95         211 $prefix.$self->_assemble_format($2, \@types).$suffix
148             }geo;
149 105         215 my %types_table = map { $_ => 1 } map {
150 23         56 my $t = $_;
  105         137  
151 105         154 $t =~ s/^localed_//;
152 105         191 $t;
153             } @types;
154              
155             # define vars
156 158         316 my $vars = join ', ', uniq map { '$'.$_ } map {
157 23         56 my $t = $_;
  151         218  
158 151 100       307 $t =~ s/^localed_// ? ($_, $t) : $_;
159             } @types, 'offset', 'epoch';
160 23         572 my $captures = join ', ', map { '$'.$_ } @types;
  105         192  
161              
162             # generate base src
163 23         47 local $" = ' ';
164 23         67 my $parser_src = <<EOD;
165             my ($vars);
166             \$offset = 0;
167             sub {
168             ($captures) = \$_[0] =~ m{^$format\$}
169             or Carp::croak 'cannot parse datetime. text: "'.\$_[0].'", format: '.\%s;
170             \%s
171             (\$epoch, \$offset);
172             };
173             EOD
174              
175             # generate formatter src
176 23         39 my $formatter_src = '';
177 23         50 for my $type (@types) {
178 105         194 $formatter_src .= $self->_gen_stash_initialize_src($type);
179             }
180 23         59 $formatter_src .= $self->_gen_calc_epoch_src(\%types_table);
181 23         72 $formatter_src .= $self->_gen_calc_offset_src(\%types_table);
182              
183 23         206 my $combined_src = sprintf $parser_src, B::perlstring(B::perlstring($self->{format})), $formatter_src;
184 23         60 $self->{parser_src} = $combined_src;
185 23         36 warn encode_utf8 "[DEBUG] src: $combined_src" if DEBUG;
186              
187 23   100     89 my $format_table = $self->{format_table} || {};
188 23         4549 eval $combined_src; ## no critic
189             };
190 23 50       80 die $@ if $@;
191              
192 23         89 return $parser;
193             }
194              
195             sub _assemble_format {
196 127     127   310 my ($self, $c, $types) = @_;
197 127         214 my ($type, $val) = @{ $self->{_handler}->{$c} };
  127         273  
198 127 50       287 die "unsupported: \%$c. patches welcome :)" if $type eq 'UNSUPPORTED';
199              
200             # normalize
201 127 100       259 if (ref $val) {
202 69 100       157 $val = $self->$val($type) if ref $val eq 'CODE';
203 69 50       568 $val = join '|', @$val if ref $val eq 'ARRAY';
204             }
205              
206             # assemble to regexp
207 127 100       260 if ($type eq 'extend') {
208 14         25 my $handlers = join '', keys %{ $self->{_handler} };
  14         73  
209 14         542 $val =~ s{([^%]*)?%([${handlers}])([^%]*)?}{
210 32   50     143 my $prefix = quotemeta($1||'');
211 32   100     96 my $suffix = quotemeta($3||'');
212 32         73 $prefix.$self->_assemble_format($2, $types).$suffix
213             }ge;
214 14         69 return $val;
215             }
216             else {
217 113 100       243 return "(?:$val)" if $type eq 'SKIP';
218 109 100       223 return quotemeta $val if $type eq 'char';
219              
220 105         158 push @$types => $type;
221 105         480 return "($val)";
222             }
223             }
224              
225             sub _gen_stash_initialize_src {
226 105     105   195 my ($self, $type) = @_;
227              
228 105 50       237 if ($type eq 'timezone') {
    100          
229 0         0 return <<'EOD';
230             $time_zone->set_timezone($timezone);
231             EOD
232             }
233             elsif ($type =~ /^localed_([a-z]+)$/) {
234 7         31 return <<EOD;
235             \$${1} = \$format_table->{localed_${1}}->{\$localed_${1}};
236             EOD
237             }
238             else {
239 98         194 return ''; # default: none
240             }
241             }
242              
243             sub _gen_calc_epoch_src {
244 23     23   44 my ($self, $types_table) = @_;
245              
246 23 50       55 my $timegm = $self->{strict} ? 'timegm' : 'timegm_nocheck';
247              
248             # hour24&minute&second
249             # year&day365 or year&month&day
250 23 100       56 my $second = $types_table->{second} ? '$second' : 0;
251 23 100       49 my $minute = $types_table->{minute} ? '$minute' : 0;
252 23         51 my $hour = $self->_gen_calc_hour_src($types_table);
253 23 100 33     131 if ($types_table->{epoch}) {
    100 66        
    100 33        
    50 33        
254 3         7 return ''; # nothing to do
255             }
256             elsif ($types_table->{year} && $types_table->{month} && $types_table->{day}) {
257 16         54 return <<EOD;
258             \$epoch = $timegm($second, $minute, $hour, \$day, \$month - 1, \$year);
259             EOD
260             }
261             elsif ($types_table->{year} && $types_table->{month}) {
262 1         5 return <<EOD;
263             \$epoch = $timegm($second, $minute, $hour, 1, \$month - 1, \$year);
264             EOD
265             }
266             elsif ($types_table->{year} && $types_table->{day365}) {
267 3         11 return <<EOD;
268             \$epoch = $timegm($second, $minute, $hour, 1, 0, \$year) + (\$day365 - 1) * 60 * 60 * 24;
269             EOD
270             }
271              
272 0         0 die 'unknown case. types: '. join ', ', keys %$types_table;
273             }
274              
275             sub _gen_calc_offset_src {
276 23     23   43 my ($self, $types_table) = @_;
277              
278 23         37 my $src = '';
279              
280 23 100       63 my $second = $types_table->{second} ? '$second' : 0;
281 23 100       47 my $minute = $types_table->{minute} ? '$minute' : 0;
282 23         42 my $hour = $self->_gen_calc_hour_src($types_table);
283              
284 23         51 my $fixed_offset = $self->_fixed_offset($types_table);
285 23 100       103 if (defined $fixed_offset) {
    50          
286 20 50       62 if ($fixed_offset != 0) {
287 0         0 $src .= sprintf <<'EOD', $fixed_offset;
288             $offset -= %d;
289             EOD
290             }
291             }
292             elsif ($types_table->{offset}) {
293 3         8 $src .= <<'EOD';
294             $offset = (abs($offset) == $offset ? 1 : -1) * (60 * 60 * substr($offset, 1, 2) + 60 * substr($offset, 3, 2));
295             EOD
296             }
297             else {
298 0         0 $src .= <<EOD;
299             \$offset = \$time_zone->offset(\$epoch);
300             EOD
301             }
302              
303 23 50 66     62 if (!defined $fixed_offset && !$types_table->{epoch}) {
304 0         0 $src .= <<'EOD'
305             $epoch -= $offset;
306             EOD
307             }
308              
309 23         51 return $src;
310             }
311              
312             sub _gen_calc_hour_src {
313 46     46   74 my ($self, $types_table) = @_;
314              
315 46 100 66     132 if ($types_table->{hour24}) {
    100          
316 18         37 return '$hour24';
317             }
318             elsif ($types_table->{hour12} && $types_table->{pm}) {
319 8         18 return '(0,12)[$pm] + ($hour12 % 12)';
320             }
321             else {
322 20         36 return '0';
323             }
324             }
325              
326             sub _fixed_offset {
327 23     23   34 my ($self, $types_table) = @_;
328 23 100       58 return if $types_table->{offset};
329 20 50       44 return if $types_table->{timezone};
330 20 50       77 return if not exists $FIXED_OFFSET{$self->{time_zone}->name};
331 20         121 return $FIXED_OFFSET{$self->{time_zone}->name};
332             }
333              
334             1;
335             __END__
336              
337             =encoding utf-8
338              
339             =for stopwords strptime
340              
341             =head1 NAME
342              
343             Time::Strptime::Format - L<strptime(3)> format compiler and parser.
344              
345             =head1 SYNOPSIS
346              
347             use Time::Strptime::Format;
348              
349             # OO style
350             my $fmt = Time::Strptime::Format->new('%Y-%m-%d %H:%M:%S');
351             my ($epoch_o, $offset_o) = $fmt->parse('2014-01-01 00:00:00');
352              
353             =head1 DESCRIPTION
354              
355             This is L<Time::Strptime> engine.
356              
357             =head1 METHODS
358              
359             This class offers the following methods.
360              
361             =head2 Time::Strptime::Format->new($format, \%args)
362              
363             This methods creates a new format object. It accepts the following arguments:
364              
365             =over 4
366              
367             =item * time_zone
368              
369             The default time zone to use for objects returned from parsing.
370              
371             =item * locale
372              
373             The locale to use for objects returned from parsing.
374              
375             =item * strict
376              
377             Strict range check for date and time.
378              
379             Example. C<"2016-02-31"> is wrong date string, but Time::Strptime parses as C<2016-02-31> in default.
380              
381             =back
382              
383             =head2 $strptime->parse($string)
384              
385             Given a string in the pattern specified in the constructor, this method will return the epoch and offset.
386             If given a string that doesn't match the pattern, the formatter will throw the error.
387              
388             =head1 STRPTIME PATTERN TOKENS
389              
390             The following tokens are allowed in the pattern string for strptime:
391              
392             =over 4
393              
394             =item * %%
395              
396             The % character.
397              
398             =item * %a or %A
399              
400             The weekday name according to the current locale, in abbreviated form or the full name. (ignored)
401              
402             =item * %b or %B or %h
403              
404             The month name according to the current locale, in abbreviated form or the full name.
405              
406             =item * %d or %e
407              
408             The day of month (01-31). This will parse single digit numbers as well.
409              
410             =item * %D
411              
412             Equivalent to %m/%d/%y. (This is the American style date, very confusing to non-Americans, especially since %d/%m/%y is widely used in Europe. The ISO 8601 standard pattern is %F.)
413              
414             =item * %F
415              
416             Equivalent to %Y-%m-%d. (This is the ISO style date)
417              
418             =item * %H
419              
420             The hour (00-23). This will parse single digit numbers as well.
421              
422             =item * %I
423              
424             The hour on a 12-hour clock (1-12).
425              
426             =item * %j
427              
428             The day number in the year (1-366).
429              
430             =item * %m
431              
432             The month number (01-12). This will parse single digit numbers as well.
433              
434             =item * %M
435              
436             The minute (00-59). This will parse single digit numbers as well.
437              
438             =item * %n
439              
440             Arbitrary white-space. (ignored)
441              
442             =item * %p
443              
444             The equivalent of AM or PM according to the locale in use. (See L<DateTime::Locale>)
445              
446             =item * %r
447              
448             Equivalent to %I:%M:%S %p.
449              
450             =item * %R
451              
452             Equivalent to %H:%M.
453              
454             =item * %s
455              
456             Number of seconds since the Epoch.
457              
458             =item * %S
459              
460             The second (0-60; 60 may occur for leap seconds.).
461              
462             =item * %t
463              
464             Tab space. (ignored)
465              
466             =item * %T
467              
468             Equivalent to %H:%M:%S.
469              
470             =item * %Y
471              
472             A 4-digit year, including century (for example, 1991).
473              
474             =item * %z
475              
476             An RFC-822/ISO 8601 standard time zone specification. (e.g. +1100)
477              
478             =item * %Z
479              
480             The time zone name. (e.g. EST)
481              
482             =back
483              
484             =head1 LICENSE
485              
486             Copyright (C) karupanerura.
487              
488             This library is free software; you can redistribute it and/or modify
489             it under the same terms as Perl itself.
490              
491             =head1 AUTHOR
492              
493             karupanerura E<lt>karupa@cpan.orgE<gt>
494              
495             =cut