1#! /bin/false
2
3# vim: set autoindent shiftwidth=4 tabstop=4:
4
5# Pure Perl implementation of Uniforum message translation.
6# Copyright (C) 2002-2017 Guido Flohr <guido.flohr@cantanea.com>,
7# all rights reserved.
8
9# This program is free software: you can redistribute it and/or modify
10# it under the terms of the GNU General Public License as published by
11# the Free Software Foundation; either version 3 of the License, or
12# (at your option) 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
17# GNU General Public License for more details.
18
19# You should have received a copy of the GNU General Public License
20# along with this program.  If not, see <http://www.gnu.org/licenses/>.
21
22package Locale::gettext_pp;
23
24use strict;
25
26require 5.004;
27
28use vars qw ($__gettext_pp_default_dir
29    		 $__gettext_pp_textdomain
30    		 $__gettext_pp_domain_bindings
31    		 $__gettext_pp_domain_codeset_bindings
32    		 $__gettext_pp_domains
33    		 $__gettext_pp_recoders
34    		 $__gettext_pp_unavailable_dirs
35    		 $__gettext_pp_domain_cache
36    		 $__gettext_pp_alias_cache
37    		 $__gettext_pp_context_glue);
38
39use locale;
40use File::Spec;
41use Locale::Messages;
42
43BEGIN {
44    $__gettext_pp_textdomain = 'messages';
45    $__gettext_pp_domain_bindings = {};
46    $__gettext_pp_domain_codeset_bindings = {};
47    $__gettext_pp_domains = {};
48    $__gettext_pp_recoders = {};
49    $__gettext_pp_unavailable_dirs = {};
50    $__gettext_pp_domain_cache = {};
51    $__gettext_pp_alias_cache = {};
52    # The separator between msgctxt and msgid in a .mo file.  */
53    $__gettext_pp_context_glue = "\004";
54
55    $__gettext_pp_default_dir = '';
56
57    for my $dir (qw (/usr/share/locale /usr/local/share/locale)) {
58    	if (-d $dir) {
59    		$__gettext_pp_default_dir = $dir;
60    		last;
61    	}
62    }
63}
64
65BEGIN {
66    	require POSIX;
67    	require Exporter;
68    	use IO::Handle;
69    	require Locale::Recode;
70
71    	local $@;
72    	my ($has_messages, $five_ok);
73
74    	$has_messages = eval '&POSIX::LC_MESSAGES';
75
76    	unless (defined $has_messages && length $has_messages) {
77    			$five_ok = ! grep {my $x = eval "&POSIX::$_" || 0; $x eq '5';}
78    							qw (LC_CTYPE
79    							   LC_NUMERIC
80    							   LC_TIME
81    							   LC_COLLATE
82    							   LC_MONETARY
83    							   LC_ALL);
84    		if ($five_ok) {
85    			$five_ok = POSIX::setlocale (5, '');
86    		}
87    	}
88
89    	if (defined $has_messages && length $has_messages) {
90eval <<'EOF';
91sub LC_MESSAGES()
92{
93    local $!; # Do not clobber errno!
94
95    return &POSIX::LC_MESSAGES;
96}
97EOF
98    	} elsif ($five_ok) {
99eval <<'EOF';
100sub 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}
108EOF
109    	} else {
110eval <<'EOF';
111sub 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}
119EOF
120    	}
121}
122
123use 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                 setlocale
170    			 LC_CTYPE
171    			 LC_NUMERIC
172    			 LC_TIME
173    			 LC_COLLATE
174    			 LC_MONETARY
175    			 LC_MESSAGES
176    			 LC_ALL);
177@ISA = qw (Exporter);
178
179my $has_nl_langinfo;
180
181sub __load_catalog;
182sub __load_domain;
183sub __locale_category;
184sub __untaint_plural_header;
185sub __compile_plural_function;
186
187sub LC_NUMERIC()
188{
189    &POSIX::LC_NUMERIC;
190}
191
192sub LC_CTYPE()
193{
194    &POSIX::LC_CTYPE;
195}
196
197sub LC_TIME()
198{
199    &POSIX::LC_TIME;
200}
201
202sub LC_COLLATE()
203{
204    &POSIX::LC_COLLATE;
205}
206
207sub LC_MONETARY()
208{
209    &POSIX::LC_MONETARY;
210}
211
212sub LC_ALL()
213{
214    &POSIX::LC_ALL;
215}
216
217sub textdomain(;$)
218{
219    my $new_domain = shift;
220
221    $__gettext_pp_textdomain = $new_domain if defined $new_domain &&
222    	length $new_domain;
223
224    return $__gettext_pp_textdomain;
225}
226
227sub bindtextdomain($;$)
228{
229    my ($domain, $directory) = @_;
230
231    my $retval;
232    if (defined $domain && length $domain) {
233    	if (defined $directory && length $directory) {
234    		$retval = $__gettext_pp_domain_bindings->{$domain}
235    			= $directory;
236    	} elsif (exists $__gettext_pp_domain_bindings->{$domain}) {
237    		$retval = $__gettext_pp_domain_bindings->{$domain};
238    	} else {
239    		$retval = $__gettext_pp_default_dir;
240    	}
241    	$retval = '/usr/share/locale' unless defined $retval &&
242    		length $retval;
243    	return $retval;
244    } else {
245    	return;
246    }
247}
248
249sub bind_textdomain_codeset($;$)
250{
251    my ($domain, $codeset) = @_;
252
253    if (defined $domain && length $domain) {
254    	if (defined $codeset && length $codeset) {
255    		return $__gettext_pp_domain_codeset_bindings->{$domain} = $codeset;
256    	} elsif (exists $__gettext_pp_domain_codeset_bindings->{$domain}) {
257    		return $__gettext_pp_domain_codeset_bindings->{$domain};
258    	}
259    }
260
261    return;
262}
263
264sub gettext($)
265{
266    my ($msgid) = @_;
267
268    return dcnpgettext ('', undef, $msgid, undef, undef, undef);
269}
270
271sub dgettext($$)
272{
273    my ($domainname, $msgid) = @_;
274
275    return dcnpgettext ($domainname, undef, $msgid, undef, undef, undef);
276}
277
278sub dcgettext($$$)
279{
280    my ($domainname, $msgid, $category) = @_;
281
282    return dcnpgettext ($domainname, undef, $msgid, undef, undef, undef);
283}
284
285sub ngettext($$$)
286{
287    my ($msgid, $msgid_plural, $n) = @_;
288
289    return dcnpgettext ('', undef, $msgid, $msgid_plural, $n, undef);
290}
291
292sub dngettext($$$$)
293{
294    my ($domainname, $msgid, $msgid_plural, $n) = @_;
295
296    return dcnpgettext ($domainname, undef, $msgid, $msgid_plural, $n, undef);
297}
298
299sub dcngettext($$$$$)
300{
301    my ($domainname, $msgid, $msgid_plural, $n, $category) = @_;
302
303    return dcnpgettext ($domainname, undef, $msgid, $msgid_plural, $n, , $category);
304}
305
306
307sub pgettext($$)
308{
309    my ($msgctxt, $msgid) = @_;
310
311    return dcnpgettext ('', $msgctxt, $msgid, undef, undef, undef);
312}
313
314sub dpgettext($$$)
315{
316    my ($domainname, $msgctxt, $msgid) = @_;
317
318    return dcnpgettext ($domainname, $msgctxt, $msgid, undef, undef, undef);
319}
320
321sub dcpgettext($$$$)
322{
323    my ($domainname, $msgctxt, $msgid, $category) = @_;
324
325    return dcnpgettext ($domainname, $msgctxt, $msgid, undef, undef, undef);
326}
327
328sub npgettext($$$$)
329{
330    my ($msgctxt, $msgid, $msgid_plural, $n) = @_;
331
332    return dcnpgettext ('', $msgctxt, $msgid, $msgid_plural, $n, undef);
333}
334
335sub dnpgettext($$$$$)
336{
337    my ($domainname, $msgctxt, $msgid, $msgid_plural, $n) = @_;
338
339    return dcnpgettext ($domainname, $msgctxt, $msgid, $msgid_plural, $n, undef);
340}
341
342# This is the actual implementation of dncpgettext.  It is also used by the
343# corresponding function in Locale::gettext_dumb.
344sub _dcnpgettext_impl {
345    my ($domainname, $msgctxt, $msgid, $msgid_plural, $n, $category,
346        $locale) = @_;
347
348    return unless defined $msgid;
349
350    my $plural = defined $msgid_plural;
351    Locale::Messages::turn_utf_8_off($msgid);
352    Locale::Messages::turn_utf_8_off($msgctxt) if defined $msgctxt;
353    my $msg_ctxt_id = defined $msgctxt ? join($__gettext_pp_context_glue, ($msgctxt, $msgid)) : $msgid;
354
355    local $!; # Do not clobber errno!
356
357    # This is also done in __load_domain but we need a proper value.
358    $domainname = $__gettext_pp_textdomain
359    	unless defined $domainname && length $domainname;
360
361    # Category is always LC_MESSAGES (other categories are ignored).
362    my $category_name = 'LC_MESSAGES';
363    $category = LC_MESSAGES;
364
365    my $domains = __load_domain ($domainname, $category, $category_name,
366                                 $locale);
367
368    my @trans = ();
369    my $domain;
370    my $found;
371    foreach my $this_domain (@$domains) {
372    	if ($this_domain && defined $this_domain->{messages}->{$msg_ctxt_id}) {
373    		@trans = @{$this_domain->{messages}->{$msg_ctxt_id}};
374    		shift @trans;
375    		$domain = $this_domain;
376    		$found = 1;
377    		last;
378    	}
379    }
380    @trans = ($msgid, $msgid_plural) unless @trans;
381
382    my $trans = $trans[0];
383    if ($plural) {
384    	if ($domain) {
385    		my $nplurals = 0;
386    		($nplurals, $plural) = &{$domain->{plural_func}} ($n);
387    		$plural = 0 unless defined $plural;
388    		$nplurals = 0 unless defined $nplurals;
389    		$plural = 0 if $nplurals <= $plural;
390    	} else {
391    		$plural = $n != 1 || 0;
392    	}
393
394    	$trans = $trans[$plural] if defined $trans[$plural];
395    }
396
397    if ($found && defined $domain->{po_header}->{charset}) {
398    	my $input_codeset = $domain->{po_header}->{charset};
399    	# Convert into output charset.
400    	my $output_codeset = $__gettext_pp_domain_codeset_bindings->{$domainname};
401
402    	$output_codeset = $ENV{OUTPUT_CHARSET} unless defined $output_codeset;
403    	$output_codeset = __get_codeset ($category, $category_name,
404    									 $domain->{locale_id})
405    		unless defined $output_codeset;
406
407    	unless (defined $output_codeset) {
408    		# Still no point.
409    		my $lc_ctype = __locale_category (POSIX::LC_CTYPE(),
410    									   'LC_CTYPE');
411    		$output_codeset = $1
412    			if $lc_ctype =~ /^[a-z]{2}(?:_[A-Z]{2})?\.([^@]+)/;
413    	}
414
415    	# No point. :-(
416    	$output_codeset = $domain->{po_header}->{charset}
417    		unless defined $output_codeset;
418
419    	if (exists $__gettext_pp_domain_cache->{$output_codeset}) {
420    		$output_codeset = $__gettext_pp_domain_cache->{$output_codeset};
421    	} else {
422    		$output_codeset = 'utf-8' if lc $output_codeset eq 'utf8';
423    		$output_codeset =
424    			$__gettext_pp_domain_cache->{$output_codeset} =
425    			Locale::Recode->resolveAlias ($output_codeset);
426    	}
427
428    	if (defined $output_codeset &&
429    		$output_codeset ne $domain->{po_header}->{charset}) {
430    		# We have to convert.
431    		my $recoder;
432
433    		if (exists
434    			$__gettext_pp_recoders->{$input_codeset}->{$output_codeset}) {
435    			$recoder = $__gettext_pp_recoders->{$input_codeset}->{$output_codeset};
436    		} else {
437    			$recoder =
438    				$__gettext_pp_recoders->{$input_codeset}->{$output_codeset} =
439    				Locale::Recode->new (from => $input_codeset,
440    									 to => $output_codeset,
441    									 );
442    		}
443
444    		$recoder->recode ($trans);
445    	}
446    }
447
448    return $trans;
449}
450
451sub dcnpgettext ($$$$$$) {
452    return &_dcnpgettext_impl;
453}
454
455sub nl_putenv ($)
456{
457    my ($envspec) = @_;
458    return unless defined $envspec;
459    return unless length $envspec;
460    return if substr ($envspec, 0, 1) eq '=';
461
462    my ($var, $value) = split /=/, $envspec, 2;
463
464    # In Perl we *could* set empty environment variables even under
465    # MS-DOS, but for compatibility reasons, we implement the
466    # brain-damaged behavior of the Microsoft putenv().
467    if ($^O eq 'MSWin32') {
468        $value = '' unless defined $value;
469        if (length $value) {
470            $ENV{$var} = $value;
471        } else {
472            delete $ENV{$var};
473        }
474    } else {
475        if (defined $value) {
476            $ENV{$var} = $value;
477        } else {
478            delete $ENV{$var};
479        }
480    }
481
482    return 1;
483}
484
485sub setlocale($;$) {
486	require POSIX;
487	&POSIX::setlocale;
488}
489
490sub __selected_locales {
491	my ($locale, $category, $category_name) = @_;
492
493    my @locales;
494    my $cache_key;
495
496    if (defined $ENV{LANGUAGE} && length $ENV{LANGUAGE}) {
497    	@locales = split /:/, $ENV{LANGUAGE};
498    	$cache_key = $ENV{LANGUAGE};
499    } elsif (!defined $locale) {
500        # The system does not have LC_MESSAGES.  Guess the value.
501    	@locales = $cache_key = __locale_category ($category,
502    	                                           $category_name);
503    } else {
504            @locales = $cache_key = $locale;
505    }
506
507	return $cache_key, @locales;
508}
509
510sub __extend_locales {
511	my (@locales) = @_;
512
513	my @tries = @locales;
514    my %locale_lookup = map { $_ => $_ } @tries;
515
516    foreach my $locale (@locales) {
517    	if ($locale =~ /^([a-z][a-z])
518    		(?:(_[A-Z][A-Z])?
519    		 (\.[-_A-Za-z0-9]+)?
520    		 )?
521    		(\@[-_A-Za-z0-9]+)?$/x) {
522
523    		if (defined $3) {
524    			defined $2 ?
525    				push @tries, $1 . $2 . $3 : push @tries, $1 . $3;
526					$locale_lookup{$tries[-1]} = $locale;
527    		}
528    		if (defined $2) {
529    			push @tries, $1 . $2;
530    			$locale_lookup{$1 . $2} = $locale;
531    		}
532    		if (defined $1) {
533    			push @tries, $1 if defined $1;
534    			$locale_lookup{$1} = $locale;
535    		}
536    	}
537    }
538
539	return \@tries, \%locale_lookup;
540}
541
542sub __load_domain {
543    my ($domainname, $category, $category_name, $locale) = @_;
544
545    # If no locale was selected for the requested locale category,
546    # l10n is disabled completely.  This matches the behavior of GNU
547    # gettext.
548    if ($category != LC_MESSAGES) {
549        # Not supported.
550        return [];
551    }
552
553    if (!defined $locale && $category != 1729) {
554        $locale = POSIX::setlocale ($category);
555        if (!defined $locale || 'C' eq $locale || 'POSIX' eq $locale) {
556            return [];
557        }
558    }
559
560    $domainname = $__gettext_pp_textdomain
561    	unless defined $domainname && length $domainname;
562
563    my $dir = bindtextdomain ($domainname, '');
564    $dir = $__gettext_pp_default_dir unless defined $dir && length $dir;
565
566    return [] unless defined $dir && length $dir;
567
568	my ($cache_key, @locales) = __selected_locales $locale, $category, $category_name;
569
570    # Have we looked that one up already?
571    my $domains = $__gettext_pp_domain_cache->{$dir}->{$cache_key}->{$category_name}->{$domainname};
572    return $domains if defined $domains;
573    return [] unless @locales;
574
575    my @dirs = ($dir);
576    my ($tries, $lookup) = __extend_locales @locales;
577
578    push @dirs, $__gettext_pp_default_dir
579		if $__gettext_pp_default_dir && $dir ne $__gettext_pp_default_dir;
580
581    my %seen;
582	my %loaded;
583    foreach my $basedir (@dirs) {
584    	foreach my $try (@$tries) {
585			# If we had already found a catalog for "xy_XY", do not try it
586			# again.
587			next if $loaded{$try};
588
589    		my $fulldir = File::Spec->catfile($basedir, $try, $category_name);
590    		next if $seen{$fulldir}++;
591
592    		# If the cache for unavailable directories is removed,
593    		# the three lines below should be replaced by:
594    		# 'next unless -d $fulldir;'
595    		next if $__gettext_pp_unavailable_dirs->{$fulldir};
596    		++$__gettext_pp_unavailable_dirs->{$fulldir} and next
597    				unless -d $fulldir;
598            my $filename = File::Spec->catfile($fulldir, "$domainname.mo");
599    		my $domain = __load_catalog $filename, $try;
600    		next unless $domain;
601
602			$loaded{$try} = 1;
603
604    		$domain->{locale_id} = $lookup->{$try};
605    		push @$domains, $domain;
606    	}
607    }
608
609    $domains = [] unless defined $domains;
610
611    $__gettext_pp_domain_cache->{$dir}
612                              ->{$cache_key}
613                              ->{$category_name}
614                              ->{$domainname} = $domains;
615
616    return $domains;
617}
618
619sub __load_catalog
620{
621    my ($filename, $locale) = @_;
622
623    # Alternatively we could check the filename for evil characters ...
624    # (Important for CGIs).
625    return unless -f $filename && -r $filename;
626
627    local $/;
628    local *HANDLE;
629
630    open HANDLE, "<$filename"
631    	or return;
632    binmode HANDLE;
633    my $raw = <HANDLE>;
634    close HANDLE;
635
636    # Corrupted?
637    return if ! defined $raw || length $raw < 28;
638
639    my $filesize = length $raw;
640
641    # Read the magic number in order to determine the byte order.
642    my $domain = {
643		filename => $filename
644	};
645    my $unpack = 'N';
646    $domain->{magic} = unpack $unpack, substr $raw, 0, 4;
647
648    if ($domain->{magic} == 0xde120495) {
649    	$unpack = 'V';
650    } elsif ($domain->{magic} != 0x950412de) {
651    	return;
652    }
653    my $domain_unpack = $unpack x 6;
654
655    my ($revision, $num_strings, $msgids_off, $msgstrs_off,
656    	$hash_size, $hash_off) =
657    		unpack (($unpack x 6), substr $raw, 4, 24);
658
659    my $major = $revision >> 16;
660    return if $major != 0; # Invalid revision number.
661
662    $domain->{revision} = $revision;
663    $domain->{num_strings} = $num_strings;
664    $domain->{msgids_off} = $msgids_off;
665    $domain->{msgstrs_off} = $msgstrs_off;
666    $domain->{hash_size} = $hash_size;
667    $domain->{hash_off} = $hash_off;
668
669    return if $msgids_off + 4 * $num_strings > $filesize;
670    return if $msgstrs_off + 4 * $num_strings > $filesize;
671
672    my @orig_tab = unpack (($unpack x (2 * $num_strings)),
673    					   substr $raw, $msgids_off, 8 * $num_strings);
674    my @trans_tab = unpack (($unpack x (2 * $num_strings)),
675    						substr $raw, $msgstrs_off, 8 * $num_strings);
676
677    my $messages = {};
678
679    for (my $count = 0; $count < 2 * $num_strings; $count += 2) {
680    	my $orig_length = $orig_tab[$count];
681    	my $orig_offset = $orig_tab[$count + 1];
682    	my $trans_length = $trans_tab[$count];
683    	my $trans_offset = $trans_tab[$count + 1];
684
685    	return if $orig_offset + $orig_length > $filesize;
686    	return if $trans_offset + $trans_length > $filesize;
687
688    	my @origs = split /\000/, substr $raw, $orig_offset, $orig_length;
689    	my @trans = split /\000/, substr $raw, $trans_offset, $trans_length;
690
691    	# The singular is the key, the plural plus all translations is the
692    	# value.
693    	my $msgid = $origs[0];
694    	$msgid = '' unless defined $msgid && length $msgid;
695    	my $msgstr = [ $origs[1], @trans ];
696    	$messages->{$msgid} = $msgstr;
697    }
698
699    $domain->{messages} = $messages;
700
701    # Try to find po header information.
702    my $po_header = {};
703    my $null_entry = $messages->{''}->[1];
704    if ($null_entry) {
705    	my @lines = split /\n/, $null_entry;
706    	foreach my $line (@lines) {
707    		my ($key, $value) = split /:/, $line, 2;
708    		$key =~ s/-/_/g;
709    		$po_header->{lc $key} = $value;
710    	}
711    }
712    $domain->{po_header} = $po_header;
713
714    if (exists $domain->{po_header}->{content_type}) {
715    	my $content_type = $domain->{po_header}->{content_type};
716    	if ($content_type =~ s/.*=//) {
717    		$domain->{po_header}->{charset} = $content_type;
718    	}
719    }
720
721    my $code = $domain->{po_header}->{plural_forms} || '';
722
723    # Whitespace, locale-independent.
724    my $s = '[ \011-\015]';
725
726    # Untaint the plural header.
727    # Keep line breaks as is (Perl 5_005 compatibility).
728    $code = $domain->{po_header}->{plural_forms}
729        = __untaint_plural_header $code;
730
731    $domain->{plural_func} = __compile_plural_function $code;
732
733    unless (defined $domain->{po_header}->{charset}
734            && length $domain->{po_header}->{charset}
735            && $locale =~ /^(?:[a-z][a-z])
736                            (?:(?:_[A-Z][A-Z])?
737                             (\.[-_A-Za-z0-9]+)?
738                            )?
739                            (?:\@[-_A-Za-z0-9]+)?$/x) {
740        $domain->{po_header}->{charset} = $1;
741    }
742
743    if (defined $domain->{po_header}->{charset}) {
744        $domain->{po_header}->{charset} =
745            Locale::Recode->resolveAlias ($domain->{po_header}->{charset});
746    }
747
748    return $domain;
749}
750
751sub __locale_category
752{
753    my ($category, $category_name) = @_;
754
755    local $@;
756    my $value = eval {POSIX::setlocale ($category)};
757
758    # We support only XPG syntax, i. e.
759    # language[_territory[.codeset]][@modifier].
760    undef $value unless (defined $value &&
761    					 length $value &&
762    					 $value =~ /^[a-z][a-z]
763    					 (?:_[A-Z][A-Z]
764    					  (?:\.[-_A-Za-z0-9]+)?
765    					  )?
766    					 (?:\@[-_A-Za-z0-9]+)?$/x);
767
768    unless ($value) {
769    	$value = $ENV{LC_ALL};
770    	$value = $ENV{$category_name} unless defined $value && length $value;
771    	$value = $ENV{LANG} unless defined $value && length $value;
772    	return 'C' unless defined $value && length $value;
773    }
774
775    return $value if $value ne 'C' && $value ne 'POSIX';
776}
777
778sub __get_codeset
779{
780    my ($category, $category_name, $locale_id) = @_;
781
782    local $@;
783    unless (defined $has_nl_langinfo) {
784    	eval {
785    		require I18N::Langinfo;
786    	};
787    	$has_nl_langinfo = !$@;
788    }
789
790    if ($has_nl_langinfo) {
791    	# Try to set the locale via the specified id.
792    	my $saved_locale = eval { POSIX::setlocale (LC_ALL) };
793    	my $had_lc_all = exists $ENV{LC_ALL};
794    	my $saved_lc_all = $ENV{LC_ALL} if $had_lc_all;
795
796    	# Now try to set the locale via the environment.  There is no
797    	# point in calling the langinfo routines if this fails.
798    	$ENV{LC_ALL} = $locale_id;
799    	my $codeset;
800    	my $lc_all = eval { POSIX::setlocale (LC_ALL, $locale_id); };
801    	$codeset = I18N::Langinfo::langinfo (I18N::Langinfo::CODESET())
802    		if defined $lc_all;
803
804        # Restore environment.
805    	if ($saved_locale) {
806    		eval { POSIX::setlocale (LC_ALL, $saved_locale); }
807    	}
808    	if ($had_lc_all) {
809            $ENV{LC_ALL} = $saved_lc_all if $had_lc_all;
810    	} else {
811    	    delete $ENV{LC_ALL};
812    	}
813    	return $codeset;
814    }
815
816    return;
817}
818
819sub __untaint_plural_header {
820    my ($code) = @_;
821
822    # Whitespace, locale-independent.
823    my $s = '[ \t\r\n\013\014]';
824
825    if ($code =~ m{^($s*
826    				 nplurals$s*=$s*[0-9]+
827    				 $s*;$s*
828    				 plural$s*=$s*(?:$s|[-\?\|\&=!<>+*/\%:;a-zA-Z0-9_\(\)])+
829    				 )}xms) {
830    	return $1;
831    }
832
833    return '';
834}
835
836sub __compile_plural_function {
837    my ($code) = @_;
838
839    # The leading and trailing space is necessary to be able to match
840    # against word boundaries.
841    my $plural_func;
842
843    if (length $code) {
844    	my $code = ' ' . $code . ' ';
845    	$code =~
846    		s/(?<=[^_a-zA-Z0-9])[_a-z][_A-Za-z0-9]*(?=[^_a-zA-Z0-9])/\$$&/gs;
847
848    	$code = "sub { my \$n = shift || 0;
849    			   my (\$plural, \$nplurals);
850    			   $code;
851    			   return (\$nplurals, \$plural ? \$plural : 0); }";
852
853    	# Now try to evaluate the code.	 There is no need to run the code in
854    	# a Safe compartment.  The above substitutions should have destroyed
855    	# all evil code.  Corrections are welcome!
856        #warn $code;
857    	$plural_func = eval $code;
858        #warn $@ if $@;
859    	undef $plural_func if $@;
860    }
861
862    # Default is Germanic plural (which is incorrect for French).
863    $plural_func = eval "sub { (2, 1 != shift || 0) }" unless $plural_func;
864
865    return $plural_func;
866}
867
8681;
869
870__END__
871
872=head1 NAME
873
874Locale::gettext_pp - Pure Perl Implementation of Uniforum Message Translation
875
876=head1 SYNOPSIS
877
878 use Locale::gettext_pp qw(:locale_h :libintl_h);
879
880 gettext $msgid;
881 dgettext $domainname, $msgid;
882 dcgettext $domainname, $msgid, LC_MESSAGES;
883 ngettext $msgid, $msgid_plural, $count;
884 dngettext $domainname, $msgid, $msgid_plural, $count;
885 dcngettext $domainname, $msgid, $msgid_plural, $count, LC_MESSAGES;
886 pgettext $msgctxt, $msgid;
887 dpgettext $domainname, $msgctxt, $msgid;
888 dcpgettext $domainname, $msgctxt, $msgid, LC_MESSAGES;
889 npgettext $msgctxt, $msgid, $msgid_plural, $count;
890 dnpgettext $domainname, $msgctxt, $msgid, $msgid_plural, $count;
891 dcnpgettext $domainname, $msgctxt, $msgid, $msgid_plural, $count, LC_MESSAGES;
892 textdomain $domainname;
893 bindtextdomain $domainname, $directory;
894 bind_textdomain_codeset $domainname, $encoding;
895 my $category = LC_CTYPE;
896 my $category = LC_NUMERIC;
897 my $category = LC_TIME;
898 my $category = LC_COLLATE;
899 my $category = LC_MONETARY;
900 my $category = LC_MESSAGES;
901 my $category = LC_ALL;
902
903=head1 DESCRIPTION
904
905The module B<Locale::gettext_pp> is the low-level interface to
906message translation according to the Uniforum approach that is
907for example used in GNU gettext and Sun's Solaris.
908
909Normally you should not use this module directly, but the high
910level interface Locale::TextDomain(3) that provides a much simpler
911interface.    This description is therefore deliberately kept
912brief.    Please refer to the GNU gettext documentation available at
913L<http://www.gnu.org/manual/gettext/> for in-depth and background
914information on the topic.
915
916=head1 FUNCTIONS
917
918The module exports by default nothing.    Every function has to be
919imported explicitely or via an export tag (L<"EXPORT TAGS">).
920
921=over 4
922
923=item B<gettext MSGID>
924
925See L<Locale::Messages/FUNCTIONS>.
926
927=item B<dgettext TEXTDOMAIN, MSGID>
928
929See L<Locale::Messages/FUNCTIONS>.
930
931=item B<dcgettext TEXTDOMAIN, MSGID, CATEGORY>
932
933See L<Locale::Messages/FUNCTIONS>.
934
935=item B<ngettext MSGID, MSGID_PLURAL, COUNT>
936
937See L<Locale::Messages/FUNCTIONS>.
938
939=item B<dngettext TEXTDOMAIN, MSGID, MSGID_PLURAL, COUNT>
940
941See L<Locale::Messages/FUNCTIONS>.
942
943=item B<dcngettext TEXTDOMAIN, MSGID, MSGID_PLURAL, COUNT, CATEGORY>
944
945See L<Locale::Messages/FUNCTIONS>.
946
947=item B<pgettext MSGCTXT, MSGID>
948
949See L<Locale::Messages/FUNCTIONS>.
950
951=item B<dpgettext TEXTDOMAIN, MSGCTXT, MSGID>
952
953See L<Locale::Messages/FUNCTIONS>.
954
955=item B<dcpgettext TEXTDOMAIN, MSGCTXT, MSGID, CATEGORY>
956
957See L<Locale::Messages/FUNCTIONS>.
958
959=item B<npgettext MSGCTXT, MSGID, MSGID_PLURAL, COUNT>
960
961See L<Locale::Messages/FUNCTIONS>.
962
963=item B<dnpgettext TEXTDOMAIN, MSGCTXT, MSGID, MSGID_PLURAL, COUNT>
964
965See L<Locale::Messages/FUNCTIONS>.
966
967=item B<dcnpgettext TEXTDOMAIN, MSGCTXT, MSGID, MSGID_PLURAL, COUNT, CATEGORY>
968
969See L<Locale::Messages/FUNCTIONS>.
970
971=item B<textdomain TEXTDOMAIN>
972
973See L<Locale::Messages/FUNCTIONS>.
974
975=item B<bindtextdomain TEXTDOMAIN, DIRECTORY>
976
977See L<Locale::Messages/FUNCTIONS>.
978
979=item B<bind_textdomain_codeset TEXTDOMAIN, ENCODING>
980
981=item B<nl_putenv ENVSPEC>
982
983See L<Locale::Messages/FUNCTIONS>.
984
985=item B<setlocale>
986
987See L<Locale::Messages/FUNCTIONS>.
988
989=back
990
991=head1 CONSTANTS
992
993You can (maybe) get the same constants from POSIX(3); see there for
994a detailed description
995
996=over 4
997
998=item B<LC_CTYPE>
999
1000=item B<LC_NUMERIC>
1001
1002=item B<LC_TIME>
1003
1004=item B<LC_COLLATE>
1005
1006=item B<LC_MONETARY>
1007
1008=item B<LC_MESSAGES>
1009
1010=item B<LC_ALL>
1011
1012See L<Locale::Messages/CONSTANTS> for more information.
1013
1014=back
1015
1016=head1 EXPORT TAGS
1017
1018This module does not export anything unless explicitely requested.
1019You can import groups of functions via two tags:
1020
1021=over 4
1022
1023=item B<use Locale::gettext_pp qw(':locale_h')>
1024
1025Imports the functions that are normally defined in the C include
1026file F<locale.h>:
1027
1028=over 8
1029
1030=item B<gettext()>
1031
1032=item B<dgettext()>
1033
1034=item B<dcgettext()>
1035
1036=item B<ngettext()>
1037
1038=item B<dngettext()>
1039
1040=item B<dcngettext()>
1041
1042=item B<pgettext()>
1043
1044Introduced with libintl-perl 1.17.
1045
1046=item B<dpgettext()>
1047
1048Introduced with libintl-perl 1.17.
1049
1050=item B<dcpgettext()>
1051
1052Introduced with libintl-perl 1.17.
1053
1054=item B<npgettext()>
1055
1056Introduced with libintl-perl 1.17.
1057
1058=item B<dnpgettext()>
1059
1060Introduced with libintl-perl 1.17.
1061
1062=item B<dcnpgettext()>
1063
1064Introduced with libintl-perl 1.17.
1065
1066=item B<textdomain()>
1067
1068=item B<bindtextdomain()>
1069
1070=item B<bind_textdomain_codeset()>
1071
1072=back
1073
1074=item B<use Locale::gettext_pp (':libintl_h')>
1075
1076Imports the locale category constants:
1077
1078=over 8
1079
1080=item B<LC_CTYPE>
1081
1082=item B<LC_NUMERIC>
1083
1084=item B<LC_TIME>
1085
1086=item B<LC_COLLATE>
1087
1088=item B<LC_MONETARY>
1089
1090=item B<LC_MESSAGES>
1091
1092=item B<LC_ALL>
1093
1094=back
1095
1096=back
1097
1098=head1 AUTHOR
1099
1100Copyright (C) 2002-2017 L<Guido Flohr|http://www.guido-flohr.net/>
1101(L<mailto:guido.flohr@cantanea.com>), all rights reserved.  See the source
1102code for details!code for details!
1103
1104=head1 SEE ALSO
1105
1106Locale::TextDomain(3pm), Locale::Messages(3pm), Encode(3pm),
1107perllocale(3pm), POSIX(3pm), perl(1), gettext(1), gettext(3)
1108
1109=cut
1110
1111Local Variables:
1112mode: perl
1113perl-indent-level: 4
1114perl-continued-statement-offset: 4
1115perl-continued-brace-offset: 0
1116perl-brace-offset: -4
1117perl-brace-imaginary-offset: 0
1118perl-label-offset: -4
1119tab-width: 4
1120End:
1121
1122=cut
1123