File Coverage

blib/lib/POSIX/strftime/Compiler.pm
Criterion Covered Total %
statement 57 108 52.7
branch 6 32 18.7
condition 3 18 16.6
subroutine 12 22 54.5
pod 3 10 30.0
total 81 190 42.6


line stmt bran cond sub pod time code
1             package POSIX::strftime::Compiler;
2              
3 4     4   226483 use 5.008001;
  4         36  
4 4     4   23 use strict;
  4         8  
  4         81  
5 4     4   18 use warnings;
  4         9  
  4         96  
6 4     4   21 use Carp;
  4         8  
  4         247  
7 4     4   1604 use Time::Local qw//;
  4         7226  
  4         107  
8 4     4   1685 use POSIX qw//;
  4         20231  
  4         123  
9 4     4   32 use base qw/Exporter/;
  4         10  
  4         585  
10              
11             our $VERSION = "0.44";
12             our @EXPORT_OK = qw/strftime/;
13              
14             use constant {
15 4         879 SEC => 0,
16             MIN => 1,
17             HOUR => 2,
18             DAY => 3,
19             MONTH => 4,
20             YEAR => 5,
21             WDAY => 6,
22             YDAY => 7,
23             ISDST => 8,
24             ISO_WEEK_START_WDAY => 1, # Monday
25             ISO_WEEK1_WDAY => 4, # Thursday
26             YDAY_MINIMUM => -366,
27 4     4   35 };
  4         9  
28              
29             BEGIN {
30 4     4   23 *tzoffset = \&_tzoffset;
31 4         14 *tzname = \&_tzname;
32              
33 4 50       8 if (eval { require Time::TZOffset; 1; }) {
  4         10158  
  0         0  
34 4     4   29 no warnings 'redefine';
  4         9  
  4         214  
35 0         0 *tzoffset = \&Time::TZOffset::tzoffset;
36             }
37             }
38              
39              
40             # copy from POSIX/strftime/GNU/PP.pm and modify
41             my @offset2zone = qw(
42             -1100 0 SST -1100 0 SST
43             -1000 0 HAST -0900 1 HADT
44             -1000 0 HST -1000 0 HST
45             -0930 0 MART -0930 0 MART
46             -0900 0 AKST -0800 1 AKDT
47             -0900 0 GAMT -0900 0 GAMT
48             -0800 0 PST -0700 1 PDT
49             -0800 0 PST -0800 0 PST
50             -0700 0 MST -0600 1 MDT
51             -0700 0 MST -0700 0 MST
52             -0600 0 CST -0500 1 CDT
53             -0600 0 GALT -0600 0 GALT
54             -0500 0 ECT -0500 0 ECT
55             -0500 0 EST -0400 1 EDT
56             -0500 1 EASST -0600 0 EAST
57             -0430 0 VET -0430 0 VET
58             -0400 0 AMT -0400 0 AMT
59             -0400 0 AST -0300 1 ADT
60             -0330 0 NST -0230 1 NDT
61             -0300 0 ART -0300 0 ART
62             -0300 0 PMST -0200 1 PMDT
63             -0300 1 AMST -0400 0 AMT
64             -0300 1 WARST -0300 1 WARST
65             -0200 0 FNT -0200 0 FNT
66             -0200 1 UYST -0300 0 UYT
67             -0100 0 AZOT +0000 1 AZOST
68             -0100 0 CVT -0100 0 CVT
69             +0000 0 GMT +0000 0 GMT
70             +0000 0 WET +0100 1 WEST
71             +0100 0 CET +0200 1 CEST
72             +0100 0 WAT +0100 0 WAT
73             +0200 0 EET +0200 0 EET
74             +0200 0 IST +0300 1 IDT
75             +0200 1 WAST +0100 0 WAT
76             +0300 0 FET +0300 0 FET
77             +030704 0 zzz +030704 0 zzz
78             +0330 0 IRST +0430 1 IRDT
79             +0400 0 AZT +0500 1 AZST
80             +0400 0 GST +0400 0 GST
81             +0430 0 AFT +0430 0 AFT
82             +0500 0 DAVT +0700 0 DAVT
83             +0500 0 MVT +0500 0 MVT
84             +0530 0 IST +0530 0 IST
85             +0545 0 NPT +0545 0 NPT
86             +0600 0 BDT +0600 0 BDT
87             +0630 0 CCT +0630 0 CCT
88             +0700 0 ICT +0700 0 ICT
89             +0800 0 HKT +0800 0 HKT
90             +0845 0 CWST +0845 0 CWST
91             +0900 0 JST +0900 0 JST
92             +0930 0 CST +0930 0 CST
93             +1000 0 PGT +1000 0 PGT
94             +1030 1 CST +0930 0 CST
95             +1100 0 CAST +0800 0 WST
96             +1100 0 NCT +1100 0 NCT
97             +1100 1 EST +1000 0 EST
98             +1100 1 LHST +1030 0 LHST
99             +1130 0 NFT +1130 0 NFT
100             +1200 0 FJT +1200 0 FJT
101             +1300 0 TKT +1300 0 TKT
102             +1300 1 NZDT +1200 0 NZST
103             +1345 1 CHADT +1245 0 CHAST
104             +1400 0 LINT +1400 0 LINT
105             +1400 1 WSDT +1300 0 WST
106             );
107              
108             sub _tzoffset {
109 0 0 0 0   0 my $diff = (exists $ENV{TZ} and $ENV{TZ} =~ m!^(?:GMT|UTC)$!)
110             ? 0
111             : Time::Local::timegm(@_) - Time::Local::timelocal(@_);
112 0         0 sprintf '%+03d%02u', $diff/60/60, $diff/60%60;
113             }
114              
115             sub _tzname {
116 0 0 0 0   0 return $ENV{TZ} if exists $ENV{TZ} and $ENV{TZ} =~ m!^(?:GMT|UTC)$!;
117              
118 0         0 my $diff = tzoffset(@_);
119              
120 0         0 my @t1 = my @t2 = @_;
121 0         0 @t1[3,4] = (1, 1); # winter
122 0         0 my $diff1 = tzoffset(@t1);
123 0         0 @t2[3,4] = (1, 7); # summer
124 0         0 my $diff2 = tzoffset(@t2);
125              
126 0         0 for (my $i=0; $i < @offset2zone; $i += 6) {
127 0 0 0     0 next unless $offset2zone[$i] eq $diff1 and $offset2zone[$i+3] eq $diff2;
128 0 0       0 return $diff2 eq $diff ? $offset2zone[$i+5] : $offset2zone[$i+2];
129             }
130              
131 0 0       0 if ($diff =~ /^([+-])(\d\d)$/) {
132 0 0       0 return sprintf 'GMT%s%d', $1 eq '-' ? '+' : '-', $2;
133             };
134              
135 0         0 return 'Etc';
136             }
137              
138             sub iso_week_days {
139 0     0 0 0 my ($yday, $wday) = @_;
140              
141             # Add enough to the first operand of % to make it nonnegative.
142 0         0 my $big_enough_multiple_of_7 = (int(- YDAY_MINIMUM / 7) + 2) * 7;
143 0         0 return ($yday
144             - ($yday - $wday + ISO_WEEK1_WDAY + $big_enough_multiple_of_7) % 7
145             + ISO_WEEK1_WDAY - ISO_WEEK_START_WDAY);
146             }
147              
148             sub isleap {
149 0     0 0 0 my $year = shift;
150 0 0 0     0 return ($year % 4 == 0 && ($year % 100 != 0 || $year % 400 == 0)) ? 1 : 0
151             }
152              
153             sub isodaysnum {
154 0     0 0 0 my @t = @_;
155              
156 0 0       0 my $year = ($t[YEAR] + ($t[YEAR] < 0 ? 1900 % 400 : 1900 % 400 - 400));
157 0         0 my $year_adjust = 0;
158 0         0 my $days = iso_week_days($t[YDAY], $t[WDAY]);
159              
160 0 0       0 if ($days < 0) {
161             # This ISO week belongs to the previous year.
162 0         0 $year_adjust = -1;
163 0         0 $days = iso_week_days($t[YDAY] + (365 + isleap($year -1)), $t[WDAY]);
164             }
165             else {
166 0         0 my $d = iso_week_days($t[YDAY] - (365 + isleap($year)), $t[WDAY]);
167 0 0       0 if ($d >= 0) {
168             # This ISO week belongs to the next year. */
169 0         0 $year_adjust = 1;
170 0         0 $days = $d;
171             }
172             }
173              
174 0         0 return ($days, $year_adjust);
175             }
176              
177             sub isoyearnum {
178 0     0 0 0 my ($days, $year_adjust) = isodaysnum(@_);
179 0         0 return $_[YEAR] + 1900 + $year_adjust;
180             }
181              
182             sub isoweeknum {
183 0     0 0 0 my ($days, $year_adjust) = isodaysnum(@_);
184 0         0 return int($days / 7) + 1;
185             }
186              
187             our %FORMAT_CHARS = map { $_ => 1 } split //, q!%aAbBcCdDeFGghHIjklmMnNpPrRsStTuUVwWxXyYzZ!;
188              
189             our %SPRINTF_CHARS = (
190             '%' => [q!%s!, q!%!],
191             'a' => [q!%s!, q!$weekday_abbr[$_[WDAY]]!],
192             'A' => [q!%s!, q!$weekday_name[$_[WDAY]]!],
193             'b' => [q!%s!, q!$month_abbr[$_[MONTH]]!],
194             'B' => [q!%s!, q!$month_name[$_[MONTH]]!],
195             'c' => [q!%s %s %2d %02d:%02d:%02d %04d!,
196             q!$weekday_abbr[$_[WDAY]], $month_abbr[$_[MONTH]], $_[DAY], $_[HOUR], $_[MIN], $_[SEC], $_[YEAR]+1900!],
197             'C' => [q!%02d!, q!($_[YEAR]+1900)/100!],
198             'd' => [q!%02d!, q!$_[DAY]!],
199             'D' => [q!%02d/%02d/%02d!, q!$_[MONTH]+1,$_[DAY],$_[YEAR]%100!],
200             'e' => [q!%2d!, q!$_[DAY]!],
201             'F' => [q!%04d-%02d-%02d!, q!$_[YEAR]+1900,$_[MONTH]+1,$_[DAY]!],
202             'h' => [q!%s!, q!$month_abbr[$_[MONTH]]!],
203             'H' => [q!%02d!, q!$_[HOUR]!],
204             'I' => [q!%02d!, q!$_[HOUR]%12 || 1!],
205             'j' => [q!%03d!, q!$_[YDAY]+1!],
206             'k' => [q!%2d!, q!$_[HOUR]!],
207             'l' => [q!%2d!, q!$_[HOUR]%12 || 1!],
208             'm' => [q!%02d!, q!$_[MONTH]+1!],
209             'M' => [q!%02d!, q!$_[MIN]!],
210             'n' => [q!%s!, q!"\n"!],
211             'N' => [q!%s!, q!substr(sprintf('%.9f', $_[SEC] - int $_[SEC]), 2)!],
212             'p' => [q!%s!, q!$_[HOUR] > 0 && $_[HOUR] < 13 ? "AM" : "PM"!],
213             'P' => [q!%s!, q!$_[HOUR] > 0 && $_[HOUR] < 13 ? "am" : "pm"!],
214             'r' => [q!%02d:%02d:%02d %s!, q!$_[HOUR]%12 || 1, $_[MIN], $_[SEC], $_[HOUR] > 0 && $_[HOUR] < 13 ? "AM" : "PM"!],
215             'R' => [q!%02d:%02d!, q!$_[HOUR], $_[MIN]!],
216             'S' => [q!%02d!, q!$_[SEC]!],
217             't' => [q!%s!, q!"\t"!],
218             'T' => [q!%02d:%02d:%02d!, q!$_[HOUR], $_[MIN], $_[SEC]!],
219             'u' => [q!%d!, q!$_[WDAY] || 7!],
220             'w' => [q!%d!, q!$_[WDAY]!],
221             'x' => [q!%02d/%02d/%02d!, q!$_[MONTH]+1,$_[DAY],$_[YEAR]%100!],
222             'X' => [q!%02d:%02d:%02d!, q!$_[HOUR], $_[MIN], $_[SEC]!],
223             'y' => [q!%02d!, q!$_[YEAR]%100!],
224             'Y' => [q!%02d!, q!$_[YEAR]+1900!],
225             '%' => [q!%s!, q!'%'!],
226             );
227              
228             if ( eval { require Time::TZOffset; 1 } ) {
229             $SPRINTF_CHARS{z} = [q!%s!,q!Time::TZOffset::tzoffset(@_)!];
230             }
231              
232             our %LOCALE_CHARS = (
233             '%' => [q!'%%'!],
234             'a' => [q!$weekday_abbr[$_[WDAY]]!,1],
235             'A' => [q!$weekday_name[$_[WDAY]]!,1],
236             'b' => [q!$month_abbr[$_[MONTH]]!],
237             'B' => [q!$month_name[$_[MONTH]]!],
238             'c' => [q!$weekday_abbr[$_[WDAY]] . ' ' . $month_abbr[$_[MONTH]] . ' ' . substr(' '.$_[DAY],-2) . ' %H:%M:%S %Y'!,1],
239             'C' => [q!substr('0'.int(($_[YEAR]+1900)/100), -2)!], #century
240             'h' => [q!$month_abbr[$_[MONTH]]!],
241             'k' => [q!substr(' '.$_[HOUR],-2)!],
242             'l' => [q!substr(' '.($_[HOUR]%12 || 1),-2)!],
243             'N' => [q!substr(sprintf('%.9f', $_[SEC] - int $_[SEC]), 2)!],
244             'n' => [q!"\n"!],
245             'p' => [q!$_[HOUR] > 0 && $_[HOUR] < 13 ? "AM" : "PM"!],
246             'P' => [q!$_[HOUR] > 0 && $_[HOUR] < 13 ? "am" : "pm"!],
247             'r' => [q!sprintf('%02d:%02d:%02d %s',$_[HOUR]%12 || 1, $_[MIN], $_[SEC], $_[HOUR] > 0 && $_[HOUR] < 13 ? "AM" : "PM")!],
248             't' => [q!"\t"!],
249             'x' => [q!'%m/%d/%y'!],
250             'X' => [q!'%H:%M:%S'!],
251             'z' => [q!'%z'!,1],
252             'Z' => [q!'%Z'!,1],
253             );
254              
255             if ( $^O =~ m!^(MSWin32|cygwin)$!i ) {
256             %LOCALE_CHARS = (
257             %LOCALE_CHARS,
258             'D' => [q!'%m/%d/%y'!],
259             'F' => [q!'%Y-%m-%d'!],
260             'G' => [q!substr('0000'. isoyearnum(@_), -4)!,1],
261             'R' => [q!'%H:%M'!],
262             'T' => [q!'%H:%M:%S'!],
263             'V' => [q!substr('0'.isoweeknum(@_),-2)!,1],
264             'e' => [q!substr(' '.$_[DAY],-2)!],
265             'g' => [q!substr('0'.isoyearnum(@_)%100,-2)!,1],
266             's' => [q!int(Time::Local::timegm(@_))!,1],
267             'u' => [q!$_[WDAY] || 7!,1],
268             'z' => [q!tzoffset(@_)!,1],
269             'Z' => [q!tzname(@_)!,1],
270             );
271             }
272             elsif ( $^O =~ m!^solaris$!i ) {
273             $LOCALE_CHARS{s} = [q!int(Time::Local::timegm(@_))!,1];
274             }
275              
276             my $sprintf_char_handler = sub {
277             my ($char,$args) = @_;
278             return q|! . '%%' .q!| if $char eq ''; #last %
279             return q|! . '%%| . $char . q|' . q!| if ! exists $FORMAT_CHARS{$char}; #escape %%
280             my ($format, $code) = @{$SPRINTF_CHARS{$char}};
281             push @$args, $code;
282             return $format;
283             };
284              
285             my $char_handler = sub {
286             my ($char,$need9char_ref) = @_;
287             return q|! . '%%' .q!| if $char eq ''; #last %
288             return q|! . '%%| . $char . q|' . q!| if ! exists $FORMAT_CHARS{$char}; #escape %%
289             return q|! . '%| . $char . q|' . q!| if ! exists $LOCALE_CHARS{$char}; #stay
290             my ($code,$flag) = @{$LOCALE_CHARS{$char}};
291             $$need9char_ref++ if $flag;
292             q|! . | . $code . q| . q!|;
293             };
294              
295             sub compile {
296 1     1 0 4 my ($fmt) = @_;
297              
298 1         6 my @weekday_name = qw(Sunday Monday Tuesday Wednesday Thursday Friday Saturday);
299 1         4 my @weekday_abbr = qw(Sun Mon Tue Wed Thu Fri Sat);
300 1         4 my @month_name = qw(January February March April May June July August September October November December);
301 1         4 my @month_abbr = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
302              
303 1         3 $fmt =~ s/!/\\!/g;
304 1         3 $fmt =~ s!\%E([cCxXyY])!%$1!g;
305 1         2 $fmt =~ s!\%O([deHImMSuUVwWy])!%$1!g;
306              
307 1         2 my $sprintf_fmt = $fmt;
308 1         2 my $disable_sprintf=0;
309 1         16 my $sprintf_code = '';
310 1         9 while ( $sprintf_fmt =~ m~ (?:\%([\%\+a-zA-Z])) ~gx ) {
311 2 50 33     20 if ( exists $FORMAT_CHARS{$1} && ! exists $SPRINTF_CHARS{$1} ) {
312 2         7 $disable_sprintf++
313             }
314             }
315 1 50       4 if ( !$disable_sprintf ) {
316 0         0 my @args;
317 0         0 $sprintf_fmt =~ s!
318             (?:
319             \%([\%\+a-zA-Z]|$)
320             )
321 0         0 ! $sprintf_char_handler->($1,\@args) !egx;
322 0         0 $sprintf_code = q~if ( @_ == 9 ) {
323             return sprintf(q!~ . $sprintf_fmt . q~!,~ . join(",", @args) . q~);
324             }~;
325             }
326              
327 1         4 my $posix_fmt = $fmt;
328 1         2 my $need9char=0;
329 1         7 $posix_fmt =~ s!
330             (?:
331             \%([\%\+a-zA-Z]|$)
332             )
333 2         8 ! $char_handler->($1,\$need9char) !egx;
334            
335 1         3 my $need9char_code='';
336 1 50       4 if ( $need9char ) {
337 0         0 $need9char_code = q~if ( @_ == 6 ) {
338             my $sec = $_[0];
339             @_ = gmtime Time::Local::timegm(@_);
340             $_[0] = $sec;
341             }~;
342             }
343 1         6 my $code = q~sub {
344             ~ . $sprintf_code . q~
345             ~ . $need9char_code . q~
346             if ( @_ != 9 && @_ != 6 ) {
347             Carp::croak 'Usage: strftime(sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1)';
348             }
349             POSIX::strftime(q!~ . $posix_fmt . q~!,@_);
350             }~;
351 1         196 my $sub = eval $code; ## no critic
352 1 50       5 die $@ ."\n=====\n".$code."\n=====\n" if $@;
353 1 50       50 wantarray ? ($sub,$code) : $sub;
354             }
355              
356             my %STRFTIME;
357             sub strftime {
358 6     6 1 100 my $fmt = shift;
359 6   66     160 ($STRFTIME{$fmt} ||= compile($fmt))->(@_);
360             }
361              
362             sub new {
363 0     0 1   my $class = shift;
364 0           my $fmt = shift;
365 0           my ($sub,$code) = compile($fmt);
366 0           bless [$sub,$code], $class;
367             }
368              
369             sub to_string {
370 0     0 1   my $self = shift;
371 0           $self->[0]->(@_);
372             }
373              
374             sub code_ref {
375 0     0 0   my $self = shift;
376 0           $self->[0];
377             }
378              
379             1;
380             __END__