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