File Coverage

blib/lib/lc_time.pm
Criterion Covered Total %
statement 17 56 30.3
branch 1 22 4.5
condition 0 9 0.0
subroutine 6 11 54.5
pod 1 1 100.0
total 25 99 25.2


line stmt bran cond sub pod time code
1             package lc_time;
2 1     1   376 use v5.10.1;
  1         3  
3 1     1   4 use warnings;
  1         2  
  1         22  
4 1     1   4 use strict;
  1         2  
  1         32  
5              
6             our $VERSION = '0.14';
7              
8             require Encode;
9              
10 1     1   228 use parent 'Exporter';
  1         212  
  1         5  
11 1     1   48 use POSIX qw/ setlocale LC_TIME LC_CTYPE LC_ALL /;
  1         2  
  1         6  
12 1 50   1   1247 use constant MY_LC_TIME => $^O eq 'MSWin32' ? LC_ALL : LC_TIME;
  1         2  
  1         479  
13              
14             our @EXPORT = qw/ strftime /;
15              
16             =head1 NAME
17              
18             lc_time - Lexical pragma for strftime.
19              
20             =head1 SYNOPSIS
21              
22             {
23             use lc_time 'nl_NL';
24             printf "Today in nl: %s\n", strftime("%d %b %Y", localtime());
25              
26             # or on Windows
27             use lc_time 'Russian_Russia';
28             printf "Today in ru: %s\n", strftime("%A %d %B %Y", localtime());
29             }
30              
31             =head1 DESCRIPTION
32              
33             This pragma switches the locale LC_TIME (or LC_ALL on windows) during the
34             C call and returns a decoded() string. C is exported by
35             default.
36              
37             =begin private
38              
39             =head2 lc_time->import()
40              
41             Set the hints-hash key B to the locale passed.
42              
43             =end private
44              
45             =cut
46              
47             sub import {
48 0     0     my $self = shift;
49 0           my ($locale) = @_;
50              
51 0           my ($pkg) = caller(0);
52 0           __PACKAGE__->export_to_level(1, $pkg, @EXPORT);
53              
54 0           $^H{pragma_LC_TIME} = $locale;
55             }
56              
57             =begin private
58              
59             =head2 lc_time->unimport()
60              
61             Clear the hints-hash key B.
62              
63             =end private
64              
65             =cut
66              
67             sub unimport {
68 0     0     $^H{pragma_LC_TIME} = undef;
69             }
70              
71             =head2 strftime($template, @localtime)
72              
73             This is a wrapper around C that checks the hints-hash key
74             b, and temporarily sets the locale LC_TIME to this value.
75             This affects the '%a', '%A', '%b' and '%B' template conversion specifications.
76              
77             =cut
78              
79             sub strftime {
80 0     0 1   my ($pattern, @arguments) = @_;
81 0           my $ctrl_h = (caller 0)[10];
82              
83 0           my ($lctime_is, $lctime_was);
84 0 0         if (my $lctime = $ctrl_h->{pragma_LC_TIME} ) {
85 0           $lctime_was = setlocale(MY_LC_TIME);
86 0 0         $lctime_is = setlocale(MY_LC_TIME, $lctime)
87             or die "Cannot set LC_TIME to '$lctime'\n";
88             }
89              
90 0           my $strftime = POSIX::strftime($pattern, @arguments);
91              
92 0 0         if ($lctime_was) {
93 0           setlocale(MY_LC_TIME, $lctime_was);
94             }
95              
96 0           my $encoding = _get_locale_encoding($lctime_is);
97 0 0         return $encoding ? Encode::decode($encoding, $strftime) : $strftime;
98             }
99              
100             sub _get_locale_encoding {
101 0     0     my $lc_time = shift;
102 0           eval 'require I18N::Langinfo;';
103 0           my $has_i18n_langinfo = !$@;
104              
105 0 0         if (!$lc_time) {
106 0 0         return $has_i18n_langinfo
107             ? I18N::Langinfo::langinfo(I18N::Langinfo::CODESET())
108             : '';
109             }
110              
111 0           my $encoding;
112 0 0         if ($has_i18n_langinfo) {
113 0           my $tmp = setlocale(LC_CTYPE);
114 0           setlocale(LC_CTYPE, $lc_time);
115 0           $encoding = I18N::Langinfo::langinfo(I18N::Langinfo::CODESET());
116 0           setlocale(LC_CTYPE, $tmp);
117             }
118              
119 0   0       $encoding ||= _guess_locale_encoding($lc_time);
120 0 0 0       if (($] > 5.021001) && ($encoding =~ /utf-?8/i)) {
121             # changed by 9717af6d049902fc887c412facb2d15e785ef1a4
122             # that patch decodes only if it's a UTF-8 locale.
123 0           $encoding = '';
124             }
125 0           return $encoding
126             }
127              
128             sub _guess_locale_encoding {
129 0     0     my $lc_time = shift;
130              
131 0           (my $encoding = $lc_time) =~ s/.+?(?:\.|$)//;
132 0 0         if ($encoding =~ /^[0-9]+$/) { # Windows cp...
133 0           $encoding = "cp$encoding";
134             }
135 0 0 0       if (!$encoding && $^O eq 'darwin') {
136 0           $encoding = 'UTF-8';
137             }
138 0           return $encoding;
139             }
140              
141             1;
142              
143             =head1 COPYRIGHT
144              
145             (c) MMXIII - Abe Timmerman
146              
147             This library is free software; you can redistribute it and/or modify
148             it under the same terms as Perl itself.
149              
150             See:
151              
152             =over 4
153              
154             =item * L
155              
156             =item * L
157              
158             =back
159              
160             This program is distributed in the hope that it will be useful,
161             but WITHOUT ANY WARRANTY; without even the implied warranty of
162             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
163              
164             =cut