gettext.pm

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