File Coverage

blib/lib/EB/CPAN/Locale/gettext_pp.pm
Criterion Covered Total %
statement 29 42 69.0
branch 1 10 10.0
condition 0 8 0.0
subroutine 6 6 100.0
pod n/a
total 36 66 54.5


line stmt bran cond sub pod time code
1              
2             # vim: set autoindent shiftwidth=4 tabstop=4:
3             # $Id$
4              
5             # Pure Perl implementation of Uniforum message translation.
6             # Copyright (C) 2002-2009 Guido Flohr ,
7             # all rights reserved.
8              
9             # This program is free software; you can redistribute it and/or modify it
10             # under the terms of the GNU Library General Public License as published
11             # by the Free Software Foundation; either version 2, or (at your option)
12             # any later version.
13              
14             # This program is distributed in the hope that it will be useful,
15             # but WITHOUT ANY WARRANTY; without even the implied warranty of
16             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
17             # Library General Public License for more details.
18              
19             # You should have received a copy of the GNU Library General Public
20             # License along with this program; if not, write to the Free Software
21             # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
22             # USA.
23              
24             package Locale::gettext_pp;
25              
26 6     6   19 use strict;
  6         5  
  6         223  
27              
28             require 5.004;
29              
30 6         487 use vars qw ($__gettext_pp_default_dir
31             $__gettext_pp_textdomain
32             $__gettext_pp_domain_bindings
33             $__gettext_pp_domain_codeset_bindings
34             $__gettext_pp_domains
35             $__gettext_pp_recoders
36             $__gettext_pp_unavailable_dirs
37             $__gettext_pp_domain_cache
38             $__gettext_pp_alias_cache
39 6     6   18 $__gettext_pp_context_glue);
  6         4  
40              
41 6     6   2605 use locale;
  6         2498  
  6         24  
42              
43             BEGIN {
44 6     6   507 $__gettext_pp_textdomain = 'messages';
45 6         9 $__gettext_pp_domain_bindings = {};
46 6         8 $__gettext_pp_domain_codeset_bindings = {};
47 6         6 $__gettext_pp_domains = {};
48 6         6 $__gettext_pp_recoders = {};
49 6         5 $__gettext_pp_unavailable_dirs = {};
50 6         5 $__gettext_pp_domain_cache = {};
51 6         5 $__gettext_pp_alias_cache = {};
52             # The separator between msgctxt and msgid in a .mo file. */
53 6         6 $__gettext_pp_context_glue = "\004";
54            
55 6         6 $__gettext_pp_default_dir = '';
56            
57 6         11 for my $dir (qw (/usr/share/locale /usr/local/share/locale)) {
58 6 50       166 if (-d $dir) {
59 6         6 $__gettext_pp_default_dir = $dir;
60 6         169 last;
61             }
62             }
63             }
64              
65             BEGIN {
66 6     6   28 require POSIX;
67 6         15 require Exporter;
68 6     6   1969 use IO::Handle;
  6         18084  
  6         911  
69 6         1206 require Locale::Recode;
70              
71 0           local $@;
72 0           my ($has_messages, $five_ok);
73            
74 0           $has_messages = eval '&POSIX::LC_MESSAGES';
75              
76 0 0 0       unless (defined $has_messages && length $has_messages) {
77 0   0       $five_ok = ! grep {my $x = eval "&POSIX::$_" || 0; $x eq '5';}
  0            
  0            
78             qw (LC_CTYPE
79             LC_NUMERIC
80             LC_TIME
81             LC_COLLATE
82             LC_MONETARY
83             LC_ALL);
84 0 0         if ($five_ok) {
85 0           $five_ok = POSIX::setlocale (5, '');
86             }
87             }
88            
89 0 0 0       if (defined $has_messages && length $has_messages) {
    0          
90 0           eval <<'EOF';
91             sub LC_MESSAGES()
92             {
93             local $!; # Do not clobber errno!
94            
95             return &POSIX::LC_MESSAGES;
96             }
97             EOF
98             } elsif ($five_ok) {
99 0           eval <<'EOF';
100             sub LC_MESSAGES()
101             {
102             local $!; # Do not clobber errno!
103              
104             # Hack: POSIX.pm deems LC_MESSAGES an invalid macro until
105             # Perl 5.8.0. However, on LC_MESSAGES should be 5 ...
106             return 5;
107             }
108             EOF
109             } else {
110 0           eval <<'EOF';
111             sub LC_MESSAGES()
112             {
113             local $!; # Do not clobber errno!
114              
115             # This fallback value is widely used,
116             # when LC_MESSAGES is not available.
117             return 1729;
118             }
119             EOF
120             }
121             }
122              
123             use vars qw (%EXPORT_TAGS @EXPORT_OK @ISA $VERSION);
124              
125             %EXPORT_TAGS = (locale_h => [ qw (
126             gettext
127             dgettext
128             dcgettext
129             ngettext
130             dngettext
131             dcngettext
132             pgettext
133             dpgettext
134             dcpgettext
135             npgettext
136             dnpgettext
137             dcnpgettext
138             textdomain
139             bindtextdomain
140             bind_textdomain_codeset
141             )
142             ],
143             libintl_h => [ qw (LC_CTYPE
144             LC_NUMERIC
145             LC_TIME
146             LC_COLLATE
147             LC_MONETARY
148             LC_MESSAGES
149             LC_ALL)
150             ],
151             );
152              
153             @EXPORT_OK = qw (gettext
154             dgettext
155             dcgettext
156             ngettext
157             dngettext
158             dcngettext
159             pgettext
160             dpgettext
161             dcpgettext
162             npgettext
163             dnpgettext
164             dcnpgettext
165             textdomain
166             bindtextdomain
167             bind_textdomain_codeset
168             nl_putenv
169             LC_CTYPE
170             LC_NUMERIC
171             LC_TIME
172             LC_COLLATE
173             LC_MONETARY
174             LC_MESSAGES
175             LC_ALL);
176             @ISA = qw (Exporter);
177              
178             my $has_nl_langinfo;
179              
180             sub __load_catalog;
181             sub __load_domain;
182             sub __locale_category;
183              
184             sub LC_NUMERIC()
185             {
186             &POSIX::LC_NUMERIC;
187             }
188              
189             sub LC_CTYPE()
190             {
191             &POSIX::LC_CTYPE;
192             }
193              
194             sub LC_TIME()
195             {
196             &POSIX::LC_TIME;
197             }
198              
199             sub LC_COLLATE()
200             {
201             &POSIX::LC_COLLATE;
202             }
203              
204             sub LC_MONETARY()
205             {
206             &POSIX::LC_MONETARY;
207             }
208              
209             sub LC_ALL()
210             {
211             &POSIX::LC_ALL;
212             }
213              
214             sub textdomain(;$)
215             {
216             my $new_domain = shift;
217            
218             $__gettext_pp_textdomain = $new_domain if defined $new_domain &&
219             length $new_domain;
220            
221             return $__gettext_pp_textdomain;
222             }
223              
224             sub bindtextdomain($;$)
225             {
226             my ($domain, $directory) = @_;
227              
228             my $retval;
229             if (defined $domain && length $domain) {
230             if (defined $directory && length $directory) {
231             $retval = $__gettext_pp_domain_bindings->{$domain}
232             = $directory;
233             } elsif (exists $__gettext_pp_domain_bindings->{$domain}) {
234             $retval = $__gettext_pp_domain_bindings->{$domain};
235             } else {
236             $retval = $__gettext_pp_default_dir;
237             }
238             $retval = '/usr/share/locale' unless defined $retval &&
239             length $retval;
240             return $retval;
241             } else {
242             return;
243             }
244             }
245              
246             sub bind_textdomain_codeset($;$)
247             {
248             my ($domain, $codeset) = @_;
249            
250             if (defined $domain && length $domain) {
251             if (defined $codeset && length $codeset) {
252             return $__gettext_pp_domain_codeset_bindings->{$domain} = $codeset;
253             } elsif (exists $__gettext_pp_domain_codeset_bindings->{$domain}) {
254             return $__gettext_pp_domain_codeset_bindings->{$domain};
255             }
256             }
257            
258             return;
259             }
260              
261             sub gettext($)
262             {
263             my ($msgid) = @_;
264              
265             return dcnpgettext ('', undef, $msgid, undef, undef, undef);
266             }
267              
268             sub dgettext($$)
269             {
270             my ($domainname, $msgid) = @_;
271              
272             return dcnpgettext ($domainname, undef, $msgid, undef, undef, undef);
273             }
274              
275             sub dcgettext($$$)
276             {
277             my ($domainname, $msgid, $category) = @_;
278              
279             return dcnpgettext ($domainname, undef, $msgid, undef, undef, undef);
280             }
281              
282             sub ngettext($$$)
283             {
284             my ($msgid, $msgid_plural, $n) = @_;
285              
286             return dcnpgettext ('', undef, $msgid, $msgid_plural, $n, undef);
287             }
288              
289             sub dngettext($$$$)
290             {
291             my ($domainname, $msgid, $msgid_plural, $n) = @_;
292              
293             return dcnpgettext ($domainname, undef, $msgid, $msgid_plural, $n, undef);
294             }
295              
296             sub dcngettext($$$$$)
297             {
298             my ($domainname, $msgid, $msgid_plural, $n, $category) = @_;
299              
300             return dcnpgettext ($domainname, undef, $msgid, $msgid_plural, $n, , $category);
301             }
302              
303              
304             sub pgettext($$)
305             {
306             my ($msgctxt, $msgid) = @_;
307              
308             return dcnpgettext ('', $msgctxt, $msgid, undef, undef, undef);
309             }
310              
311             sub dpgettext($$$)
312             {
313             my ($domainname, $msgctxt, $msgid) = @_;
314              
315             return dcnpgettext ($domainname, $msgctxt, $msgid, undef, undef, undef);
316             }
317              
318             sub dcpgettext($$$$)
319             {
320             my ($domainname, $msgctxt, $msgid, $category) = @_;
321              
322             return dcnpgettext ($domainname, $msgctxt, $msgid, undef, undef, undef);
323             }
324              
325             sub npgettext($$$$)
326             {
327             my ($msgctxt, $msgid, $msgid_plural, $n) = @_;
328              
329             return dcnpgettext ('', $msgctxt, $msgid, $msgid_plural, $n, undef);
330             }
331              
332             sub dnpgettext($$$$$)
333             {
334             my ($domainname, $msgctxt, $msgid, $msgid_plural, $n) = @_;
335              
336             return dcnpgettext ($domainname, $msgctxt, $msgid, $msgid_plural, $n, undef);
337             }
338              
339             sub dcnpgettext($$$$$$)
340             {
341             my ($domainname, $msgctxt, $msgid, $msgid_plural, $n, $category) = @_;
342              
343             return unless defined $msgid;
344              
345             my $plural = defined $msgid_plural;
346             my $msg_ctxt_id = defined $msgctxt ? join($__gettext_pp_context_glue, ($msgctxt, $msgid)) : $msgid;
347            
348             local $!; # Do not clobber errno!
349            
350             # This is also done in __load_domain but we need a proper value.
351             $domainname = $__gettext_pp_textdomain
352             unless defined $domainname && length $domainname;
353            
354             # Category is always LC_MESSAGES (other categories are ignored).
355             my $category_name = 'LC_MESSAGES';
356             $category = LC_MESSAGES;
357            
358             my $domains = __load_domain ($domainname, $category, $category_name);
359            
360             my @trans = ();
361             my $domain;
362             my $found;
363             foreach my $this_domain (@$domains) {
364             if ($this_domain && defined $this_domain->{messages}->{$msg_ctxt_id}) {
365             @trans = @{$this_domain->{messages}->{$msg_ctxt_id}};
366             shift @trans;
367             $domain = $this_domain;
368             $found = 1;
369             last;
370             }
371             }
372             @trans = ($msgid, $msgid_plural) unless @trans;
373            
374             my $trans = $trans[0];
375             if ($plural) {
376             if ($domain) {
377             my $nplurals = 0;
378             ($nplurals, $plural) = &{$domain->{plural_func}} ($n);
379             $plural = 0 unless defined $plural;
380             $nplurals = 0 unless defined $nplurals;
381             $plural = 0 if $nplurals <= $plural;
382             } else {
383             $plural = $n != 1 || 0;
384             }
385            
386             $trans = $trans[$plural] if defined $trans[$plural];
387             }
388            
389             if ($found && defined $domain->{po_header}->{charset}) {
390             my $input_codeset = $domain->{po_header}->{charset};
391             # Convert into output charset.
392             my $output_codeset = $__gettext_pp_domain_codeset_bindings->{$domainname};
393              
394             $output_codeset = $ENV{OUTPUT_CHARSET} unless defined $output_codeset;
395             $output_codeset = __get_codeset ($category, $category_name,
396             $domain->{locale_id})
397             unless defined $output_codeset;
398            
399             unless (defined $output_codeset) {
400             # Still no point.
401             my $lc_ctype = __locale_category (POSIX::LC_CTYPE(),
402             'LC_CTYPE');
403             $output_codeset = $1
404             if $lc_ctype =~ /^[a-z]{2}(?:_[A-Z]{2})?\.([^@]+)/;
405             }
406              
407             # No point. :-(
408             $output_codeset = $domain->{po_header}->{charset}
409             unless defined $output_codeset;
410            
411             if (exists $__gettext_pp_domain_cache->{$output_codeset}) {
412             $output_codeset = $__gettext_pp_domain_cache->{$output_codeset};
413             } else {
414             $output_codeset = 'utf-8' if lc $output_codeset eq 'utf8';
415             $output_codeset =
416             $__gettext_pp_domain_cache->{$output_codeset} =
417             Locale::Recode->resolveAlias ($output_codeset);
418             }
419            
420             if (defined $output_codeset &&
421             $output_codeset ne $domain->{po_header}->{charset}) {
422             # We have to convert.
423             my $recoder;
424            
425             if (exists
426             $__gettext_pp_recoders->{$input_codeset}->{$output_codeset}) {
427             $recoder = $__gettext_pp_recoders->{$input_codeset}->{$output_codeset};
428             } else {
429             $recoder =
430             $__gettext_pp_recoders->{$input_codeset}->{$output_codeset} =
431             Locale::Recode->new (from => $input_codeset,
432             to => $output_codeset,
433             );
434             }
435            
436             $recoder->recode ($trans);
437             }
438             }
439            
440             return $trans;
441             }
442              
443             sub nl_putenv ($)
444             {
445             my ($envspec) = @_;
446             return unless defined $envspec;
447             return unless length $envspec;
448             return if substr ($envspec, 0, 1) eq '=';
449            
450             my ($var, $value) = split /=/, $envspec, 2;
451              
452             # In Perl we *could* set empty environment variables even under
453             # MS-DOS, but for compatibility reasons, we implement the
454             # brain-damaged behavior of the Microsoft putenv().
455             if ($^O eq 'MSWin32') {
456             $value = '' unless defined $value;
457             if (length $value) {
458             $ENV{$var} = $value;
459             } else {
460             delete $ENV{$var};
461             }
462             } else {
463             if (defined $value) {
464             $ENV{$var} = $value;
465             } else {
466             delete $ENV{$var};
467             }
468             }
469              
470             return 1;
471             }
472              
473             sub __load_domain
474             {
475             my ($domainname, $category, $category_name) = @_;
476            
477             $domainname = $__gettext_pp_textdomain
478             unless defined $domainname && length $domainname;
479              
480             my $dir = bindtextdomain ($domainname, '');
481             $dir = $__gettext_pp_default_dir unless defined $dir && length $dir;
482             return [] unless defined $dir && length $dir;
483              
484             my @locales;
485             my $cache_key;
486              
487             if (defined $ENV{LANGUAGE} && length $ENV{LANGUAGE}) {
488             @locales = split /:/, $ENV{LANGUAGE};
489             $cache_key = $ENV{LANGUAGE};
490             } else {
491             @locales = $cache_key = __locale_category ($category, $category_name);
492             }
493              
494             # Have we looked that one up already?
495             my $domains = $__gettext_pp_domain_cache->{$dir}->{$cache_key}->{$category_name}->{$domainname};
496            
497             if (@locales && !defined $domains) {
498             my @dirs = ($dir);
499             my @tries = (@locales);
500             my %locale_lookup = map { $_ => $_ } @tries;
501              
502             foreach my $locale (@locales) {
503             if ($locale =~ /^([a-z][a-z])
504             (?:(_[A-Z][A-Z])?
505             (\.[-_A-Za-z0-9]+)?
506             )?
507             (\@[-_A-Za-z0-9]+)?$/x) {
508            
509             if (defined $3) {
510             defined $2 ?
511             push @tries, $1 . $2 . $3 : push @tries, $1 . $3;
512             }
513             if (defined $2) {
514             push @tries, $1 . $2;
515             $locale_lookup{$1 . $2} = $locale;
516             }
517             if (defined $1) {
518             push @tries, $1 if defined $1;
519             $locale_lookup{$1} = $locale;
520             }
521             }
522             }
523              
524             push @dirs, $__gettext_pp_default_dir
525             if $__gettext_pp_default_dir && $dir ne $__gettext_pp_default_dir;
526            
527             my %seen = ();
528             foreach my $basedir (@dirs) {
529             foreach my $try (@tries) {
530             my $fulldir = "$basedir/$try/$category_name";
531            
532             next if $seen{$fulldir}++;
533              
534             # If the cache for unavailable directories is removed,
535             # the three lines below should be replaced by:
536             # 'next unless -d $fulldir;'
537             next if $__gettext_pp_unavailable_dirs->{$fulldir};
538             ++$__gettext_pp_unavailable_dirs->{$fulldir} and next
539             unless -d $fulldir;
540              
541             my $domain = __load_catalog $fulldir, $domainname;
542             next unless $domain;
543            
544             unless (defined $domain->{po_header}->{charset} &&
545             length $domain->{po_header}->{charset} &&
546             $try =~ /^(?:[a-z][a-z])
547             (?:(?:_[A-Z][A-Z])?
548             (\.[-_A-Za-z0-9]+)?
549             )?
550             (?:\@[-_A-Za-z0-9]+)?$/x) {
551             $domain->{po_header}->{charset} = $1;
552             }
553            
554             if (defined $domain->{po_header}->{charset}) {
555             $domain->{po_header}->{charset} =
556             Locale::Recode->resolveAlias ($domain->{po_header}->{charset});
557             }
558             $domain->{locale_id} = $locale_lookup{$try};
559             push @$domains, $domain;
560             }
561             }
562             $__gettext_pp_domain_cache->{$dir}->{$cache_key}->{$category_name}->{$domainname} = $domains;
563             }
564              
565             $domains = [] unless defined $domains;
566             return $domains;
567             }
568              
569             sub __load_catalog
570             {
571             my ($directory, $domainname) = @_;
572            
573             my $filename = "$directory/$domainname.mo";
574            
575             # Alternatively we could check the filename for evil characters ...
576             # (Important for CGIs).
577             return unless -f $filename && -r $filename;
578            
579             local $/;
580             local *HANDLE;
581            
582             open HANDLE, "<$filename"
583             or return;
584             binmode HANDLE;
585             my $raw = ;
586             close HANDLE;
587            
588             # Corrupted?
589             return if ! defined $raw || length $raw < 28;
590            
591             my $filesize = length $raw;
592            
593             # Read the magic number in order to determine the byte order.
594             my $domain = {};
595             my $unpack = 'N';
596             $domain->{potter} = unpack $unpack, substr $raw, 0, 4;
597            
598             if ($domain->{potter} == 0xde120495) {
599             $unpack = 'V';
600             } elsif ($domain->{potter} != 0x950412de) {
601             return;
602             }
603             my $domain_unpack = $unpack x 6;
604            
605             my ($revision, $num_strings, $msgids_off, $msgstrs_off,
606             $hash_size, $hash_off) =
607             unpack (($unpack x 6), substr $raw, 4, 24);
608            
609             return unless $revision == 0; # Invalid revision number.
610            
611             $domain->{revision} = $revision;
612             $domain->{num_strings} = $num_strings;
613             $domain->{msgids_off} = $msgids_off;
614             $domain->{msgstrs_off} = $msgstrs_off;
615             $domain->{hash_size} = $hash_size;
616             $domain->{hash_off} = $hash_off;
617            
618             return if $msgids_off + 4 * $num_strings > $filesize;
619             return if $msgstrs_off + 4 * $num_strings > $filesize;
620            
621             my @orig_tab = unpack (($unpack x (2 * $num_strings)),
622             substr $raw, $msgids_off, 8 * $num_strings);
623             my @trans_tab = unpack (($unpack x (2 * $num_strings)),
624             substr $raw, $msgstrs_off, 8 * $num_strings);
625            
626             my $messages = {};
627            
628             for (my $count = 0; $count < 2 * $num_strings; $count += 2) {
629             my $orig_length = $orig_tab[$count];
630             my $orig_offset = $orig_tab[$count + 1];
631             my $trans_length = $trans_tab[$count];
632             my $trans_offset = $trans_tab[$count + 1];
633            
634             return if $orig_offset + $orig_length > $filesize;
635             return if $trans_offset + $trans_length > $filesize;
636            
637             my @origs = split /\000/, substr $raw, $orig_offset, $orig_length;
638             my @trans = split /\000/, substr $raw, $trans_offset, $trans_length;
639            
640             # The singular is the key, the plural plus all translations is the
641             # value.
642             my $msgid = $origs[0];
643             $msgid = '' unless defined $msgid && length $msgid;
644             my $msgstr = [ $origs[1], @trans ];
645             $messages->{$msgid} = $msgstr;
646             }
647            
648             $domain->{messages} = $messages;
649            
650             # Try to find po header information.
651             my $po_header = {};
652             my $null_entry = $messages->{''}->[1];
653             if ($null_entry) {
654             my @lines = split /\n/, $null_entry;
655             foreach my $line (@lines) {
656             my ($key, $value) = split /:/, $line, 2;
657             $key =~ s/-/_/g;
658             $po_header->{lc $key} = $value;
659             }
660             }
661             $domain->{po_header} = $po_header;
662            
663             if (exists $domain->{po_header}->{content_type}) {
664             my $content_type = $domain->{po_header}->{content_type};
665             if ($content_type =~ s/.*=//) {
666             $domain->{po_header}->{charset} = $content_type;
667             }
668             }
669            
670             my $code = $domain->{po_header}->{plural_forms} || '';
671            
672             # Whitespace, locale-independent.
673             my $s = '[ \t\r\n\013\014]';
674            
675             # Untaint the plural header.
676             # Keep line breaks as is (Perl 5_005 compatibility).
677             if ($code =~ m{^($s*
678             nplurals$s*=$s*[0-9]+
679             $s*;$s*
680             plural$s*=$s*(?:$s|[-\?\|\&=!<>+*/\%:;a-zA-Z0-9_\(\)])+
681             )}xms) {
682             $domain->{po_header}->{plural_forms} = $1;
683             } else {
684             $domain->{po_header}->{plural_forms} = '';
685             }
686            
687             # Determine plural rules.
688             # The leading and trailing space is necessary to be able to match
689             # against word boundaries.
690             my $plural_func;
691            
692             if ($domain->{po_header}->{plural_forms}) {
693             my $code = ' ' . $domain->{po_header}->{plural_forms} . ' ';
694             $code =~
695             s/([^_a-zA-Z0-9]|\A)([_a-z][_A-Za-z0-9]*)([^_a-zA-Z0-9])/$1\$$2$3/g;
696            
697             $code = "sub { my \$n = shift;
698             my (\$plural, \$nplurals);
699             $code;
700             return (\$nplurals, \$plural ? \$plural : 0); }";
701            
702             # Now try to evaluate the code. There is no need to run the code in
703             # a Safe compartment. The above substitutions should have destroyed
704             # all evil code. Corrections are welcome!
705             $plural_func = eval $code;
706             undef $plural_func if $@;
707             }
708            
709             # Default is Germanic plural (which is incorrect for French).
710             $plural_func = eval "sub { (2, 1 != shift || 0) }" unless $plural_func;
711            
712             $domain->{plural_func} = $plural_func;
713            
714             return $domain;
715             }
716              
717             sub __locale_category
718             {
719             my ($category, $category_name) = @_;
720            
721             local $@;
722             my $value = eval {POSIX::setlocale ($category)};
723            
724             # We support only XPG syntax, i. e.
725             # language[_territory[.codeset]][@modifier].
726             undef $value unless (defined $value &&
727             length $value &&
728             $value =~ /^[a-z][a-z]
729             (?:_[A-Z][A-Z]
730             (?:\.[-_A-Za-z0-9]+)?
731             )?
732             (?:\@[-_A-Za-z0-9]+)?$/x);
733            
734             unless ($value) {
735             $value = $ENV{LC_ALL};
736             $value = $ENV{$category_name} unless defined $value && length $value;
737             $value = $ENV{LANG} unless defined $value && length $value;
738             return 'C' unless defined $value && length $value;
739             }
740            
741             return $value if $value ne 'C' && $value ne 'POSIX';
742             }
743              
744             sub __get_codeset
745             {
746             my ($category, $category_name, $locale_id) = @_;
747              
748             local $@;
749             unless (defined $has_nl_langinfo) {
750             eval {
751             require I18N::Langinfo;
752             };
753             $has_nl_langinfo = !$@;
754             }
755              
756             if ($has_nl_langinfo) {
757             # Try to set the locale via the specified id.
758             my $saved_locale = eval { POSIX::setlocale (LC_ALL) };
759             my $saved_lc_all = $ENV{LC_ALL};
760              
761             # Now try to set the locale via the environment. There is no
762             # point in calling the langinfo routines if this fails.
763             $ENV{LC_ALL} = $locale_id;
764             my $codeset;
765             my $lc_all = eval { POSIX::setlocale (LC_ALL, $locale_id); };
766             $codeset = I18N::Langinfo::langinfo (I18N::Langinfo::CODESET())
767             if defined $lc_all;
768              
769             if ($saved_locale) {
770             eval { POSIX::setlocale (LC_ALL, $saved_locale); }
771             }
772             return $codeset;
773             }
774              
775             return;
776             }
777            
778             1;
779              
780             __END__