/usr/lib/perl5/Locale/gettext.pm is in liblocale-gettext-perl 1.05-7build1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 | package Locale::gettext;
=head1 NAME
Locale::gettext - message handling functions
=head1 SYNOPSIS
use Locale::gettext;
use POSIX; # Needed for setlocale()
setlocale(LC_MESSAGES, "");
# OO interface
my $d = Locale::gettext->domain("my_program");
print $d->get("Welcome to my program"), "\n";
# (printed in the local language)
# Direct access to C functions
textdomain("my_program");
print gettext("Welcome to my program"), "\n";
# (printed in the local language)
=head1 DESCRIPTION
The gettext module permits access from perl to the gettext() family of
functions for retrieving message strings from databases constructed
to internationalize software.
=cut
use Carp;
use POSIX qw(:locale_h);
require Exporter;
require DynaLoader;
@ISA = qw(Exporter DynaLoader);
BEGIN {
eval {
require Encode;
$encode_available = 1;
};
import Encode if ($encode_available);
}
$VERSION = "1.05" ;
%EXPORT_TAGS = (
locale_h => [qw(LC_CTYPE LC_NUMERIC LC_TIME LC_COLLATE LC_MONETARY LC_MESSAGES LC_ALL)],
libintl_h => [qw(gettext textdomain bindtextdomain dcgettext dgettext ngettext dngettext dcngettext bind_textdomain_codeset)],
);
Exporter::export_tags();
@EXPORT_OK = qw(
);
bootstrap Locale::gettext $VERSION;
sub AUTOLOAD {
local $! = 0;
my $constname = $AUTOLOAD;
$constname =~ s/.*:://;
my $val = constant($constname, (@_ ? $_[0] : 0));
if ($! == 0) {
*$AUTOLOAD = sub { $val };
}
else {
croak "Missing constant $constname";
}
goto &$AUTOLOAD;
}
=over 2
=item $d = Locale::gettext->domain(DOMAIN)
=item $d = Locale::gettext->domain_raw(DOMAIN)
Creates a new object for retrieving strings in the domain B<DOMAIN>
and returns it. C<domain> requests that strings be returned as
Perl strings (possibly with wide characters) if possible while
C<domain_raw> requests that octet strings directly from functions
like C<dgettext()>.
=cut
sub domain_raw {
my ($class, $domain) = @_;
my $self = { domain => $domain, raw => 1 };
bless $self, $class;
}
sub domain {
my ($class, $domain) = @_;
unless ($encode_available) {
croak "Encode module not available, cannot use Locale::gettext->domain";
}
my $self = { domain => $domain, raw => 0 };
bless $self, $class;
eval { bind_textdomain_codeset($self->{domain}, "UTF-8"); };
if ($@ =~ /not implemented/) {
# emulate it
$self->{emulate} = 1;
} elsif ($@ ne '') {
die; # some other problem
}
$self;
}
=item $d->get(MSGID)
Calls C<dgettext()> to return the translated string for the given
B<MSGID>.
=cut
sub get {
my ($self, $msgid) = @_;
$self->_convert(dgettext($self->{domain}, $msgid));
}
=item $d->cget(MSGID, CATEGORY)
Calls C<dcgettext()> to return the translated string for the given
B<MSGID> in the given B<CATEGORY>.
=cut
sub cget {
my ($self, $msgid, $category) = @_;
$self->_convert(dcgettext($self->{domain}, $msgid, $category));
}
=item $d->nget(MSGID, MSGID_PLURAL, N)
Calls C<dngettext()> to return the translated string for the given
B<MSGID> or B<MSGID_PLURAL> depending on B<N>.
=cut
sub nget {
my ($self, $msgid, $msgid_plural, $n) = @_;
$self->_convert(dngettext($self->{domain}, $msgid, $msgid_plural, $n));
}
=item $d->ncget(MSGID, MSGID_PLURAL, N, CATEGORY)
Calls C<dngettext()> to return the translated string for the given
B<MSGID> or B<MSGID_PLURAL> depending on B<N> in the given
B<CATEGORY>.
=cut
sub ncget {
my ($self, $msgid, $msgid_plural, $n, $category) = @_;
$self->_convert(dcngettext($self->{domain}, $msgid, $msgid_plural, $n, $category));
}
=item $d->dir([NEWDIR])
If B<NEWDIR> is given, calls C<bindtextdomain> to set the
name of the directory where messages for the domain
represented by C<$d> are found. Returns the (possibly changed)
current directory name.
=cut
sub dir {
my ($self, $newdir) = @_;
if (defined($newdir)) {
bindtextdomain($self->{domain}, $newdir);
} else {
bindtextdomain($self->{domain});
}
}
=item $d->codeset([NEWCODE])
For instances created with C<Locale::gettext-E<gt>domain_raw>, manuiplates
the character set of the returned strings.
If B<NEWCODE> is given, calls C<bind_textdomain_codeset> to set the
character encoding in which messages for the domain
represented by C<$d> are returned. Returns the (possibly changed)
current encoding name.
=cut
sub codeset {
my ($self, $codeset) = @_;
if ($self->{raw} < 1) {
warn "Locale::gettext->codeset: meaningful only for instances created with domain_raw";
return;
}
if (defined($codeset)) {
bind_textdomain_codeset($self->{domain}, $codeset);
} else {
bind_textdomain_codeset($self->{domain});
}
}
sub _convert {
my ($self, $str) = @_;
return $str if ($self->{raw});
# thanks to the use of UTF-8 in bind_textdomain_codeset, the
# result should always be valid UTF-8 when raw mode is not used.
if ($self->{emulate}) {
delete $self->{emulate};
$self->{raw} = 1;
my $null = $self->get("");
if ($null =~ /charset=(\S+)/) {
$self->{decode_from} = $1;
$self->{raw} = 0;
} #else matches the behaviour of glibc - no null entry
# means no conversion is done
}
if ($self->{decode_from}) {
return decode($self->{decode_from}, $str);
} else {
return decode_utf8($str);
}
}
sub DESTROY {
my ($self) = @_;
}
=back
gettext(), dgettext(), and dcgettext() attempt to retrieve a string
matching their C<msgid> parameter within the context of the current
locale. dcgettext() takes the message's category and the text domain
as parameters while dgettext() defaults to the LC_MESSAGES category
and gettext() defaults to LC_MESSAGES and uses the current text domain.
If the string is not found in the database, then C<msgid> is returned.
ngettext(), dngettext(), and dcngettext() function similarily but
implement differentiation of messages between singular and plural.
See the documentation for the corresponding C functions for details.
textdomain() sets the current text domain and returns the previously
active domain.
I<bindtextdomain(domain, dirname)> instructs the retrieval functions to look
for the databases belonging to domain C<domain> in the directory
C<dirname>
I<bind_textdomain_codeset(domain, codeset)> instructs the retrieval
functions to translate the returned messages to the character encoding
given by B<codeset> if the encoding of the message catalog is known.
=head1 NOTES
Not all platforms provide all of the functions. Functions that are
not available in the underlying C library will not be available in
Perl either.
Perl programs should use the object interface. In addition to being
able to return native Perl wide character strings,
C<bind_textdomain_codeset> will be emulated if the C library does
not provide it.
=head1 VERSION
1.05.
=head1 SEE ALSO
gettext(3i), gettext(1), msgfmt(1)
=head1 AUTHOR
Phillip Vandry <vandry@TZoNE.ORG>
=cut
1;
|