File Coverage

blib/lib/Gettext.pm

Criterion	Covered	Total	%
statement	12	54	22.2
branch	0	16	0.0
condition	0	34	0.0
subroutine	4	11	36.3
pod	0	7	0.0
total	16	122	13.1

package Gettext;
use strict;

use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);

use POSIX 'locale_h';
use locale;

require Exporter;
require AutoLoader;

@ISA = qw(Exporter AutoLoader);
# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.
@EXPORT = qw( );

$VERSION = '0.01';

# Preloaded methods go here.

# Autoload methods go after =cut, and are processed by the autosplit program.

   my $gettextcmd = ( -e '/bin/gettext' ? '/bin/gettext' : '/usr/bin/gettext' );

sub new {
   my $proto = shift;
   my $class = ref($proto) || $proto;
   my $self = {};

   $self->{'DOMAINNAME'} = untaint($ENV{'DOMAINNAME'}) || 'messages';
   $self->{'DIRNAME'} = untaint($ENV{'TEXTDOMAINDIR'}) || ( -d '/usr/lib/locale' ? '/usr/lib/locale' : '/usr/share/locale' );

   bless($self, $class);

   return $self;
}

sub bindtextdomain {
   my $self = shift;
   my ($domainname, $dirname) = @_;

   return '' if not defined $domainname or $domainname eq '';

   return $self->{'DIRNAME'} if not defined $dirname or $dirname eq '';

   $self->{'DOMAINNAME'} = $domainname;
   $self->{'DIRNAME'} = $dirname;

   return $dirname;
}

sub textdomain {
   my $self = shift;
   my ($domainname) = @_;

   return $self->{'DOMAINNAME'} if not defined $domainname;

   if ($domainname eq '') {
      $self->{'DOMAINNAME'} = 'messages'
   }
   else {
      # really should be input validation for a valid filespec ...
      $self->{'DOMAINNAME'} = $domainname;
   }

   return $self->{'DOMAINNAME'};
}

sub gettext {
   my $self = shift;
   my ($msgid) = @_;

   # Even more checking should be done here (and LC_CTYPE changed to LC_MESSAGES when Perl supports LC_MESSAGES) ...

   if ((not defined $ENV{'NLSPATH'} or $ENV{'NLSPATH'} eq '') and
       (setlocale(LC_CTYPE) eq 'C')) {
      return $msgid;
   }

   my $oldlocale = setlocale(LC_CTYPE);

   return `LC_MESSAGES=$oldlocale;LANGUAGE=$oldlocale;TEXTDOMAINDIR=$self->{'DIRNAME'};$gettextcmd $self->{'DOMAINNAME'} $msgid`;
}

sub dgettext {
   my $self = shift;
   my ($domainname, $msgid) = @_;

   # Even more checking should be done here (and LC_CTYPE changed to LC_MESSAGES when Perl supports LC_MESSAGES) ...

   if ((not defined $ENV{'NLSPATH'} or $ENV{'NLSPATH'} eq '') and
       (setlocale(LC_CTYPE) eq 'C')) {
      return $msgid;
   }

   my $oldlocale = setlocale(LC_CTYPE);

   return `LC_MESSAGES=$oldlocale;LANGUAGE=$oldlocale;TEXTDOMAINDIR=$self->{'DIRNAME'};$gettextcmd $domainname $msgid`;
}

sub dcgettext {
   my $self = shift;
   my ($domainname, $msgid, $category) = @_;

   # Even more checking should be done here (and LC_CTYPE changed to LC_MESSAGES when Perl supports LC_MESSAGES) ...

   if ((not defined $ENV{'NLSPATH'} or $ENV{'NLSPATH'} eq '') and
       (setlocale(LC_CTYPE) eq 'C')) {
      return $msgid;
   }

   # the env must be set, but this is kind of a shotgun approach ...
   return `LANGUAGE=$category;LC_MESSAGES=$category;TEXTDOMAINDIR=$self->{'DIRNAME'};$gettextcmd $domainname $msgid`;
}

sub untaint {
   my $str = shift || '';

   return '' if $str eq '';

   $str =~ s/[^\w.\\\/-]//g;

   return $str;
}

1;
__END__