File: gettext.pm

package info (click to toggle)
liblocale-gettext-perl 1.07-3
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, buster, sid, stretch
  • size: 140 kB
  • ctags: 21
  • sloc: perl: 248; makefile: 16
file content (283 lines) | stat: -rw-r--r-- 6,854 bytes parent folder | download
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.07" ;

%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.07.

=head1 SEE ALSO

gettext(3i), gettext(1), msgfmt(1)

=head1 AUTHOR

Kim Vandry <vandry@TZoNE.ORG>

=cut

1;