File Coverage

blib/lib/Lingua/Any/Numbers.pm

Criterion	Covered	Total	%
statement	202	227	88.9
branch	58	80	72.5
condition	35	62	56.4
subroutine	34	40	85.0
pod	1	1	100.0
total	330	410	80.4

package Lingua::Any::Numbers;
use strict;
use warnings;
use vars qw( $VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS );

$VERSION = '0.45';

use subs qw(
   to_string
   num2str
   number_to_string

   to_ordinal
   num2ord
   number_to_ordinal

   available
   available_langs
   available_languages
);

use constant LCLASS         => 0;
use constant RE_LEGACY_PERL => qr{
   Perl \s+ (.+?) \s+ required
   --this \s+ is \s+ only \s+ (.+?),
   \s+ stopped
}xmsi;
use File::Spec;
use base qw( Exporter );
use Carp qw(croak);

BEGIN {
   *num2str         = *number_to_string    = \&to_string;
   *num2ord         = *number_to_ordinal   = \&to_ordinal;
   *available_langs = *available_languages = \&available;

   @EXPORT          = ();
   @EXPORT_OK       = qw(
      to_string  number_to_string  num2str
      to_ordinal number_to_ordinal num2ord
      available  available_langs   available_languages
      language_handler
   );
}

%EXPORT_TAGS = (
   all       => [ @EXPORT_OK ],
   standard  => [ qw/ available           to_string        to_ordinal        / ],
   standard2 => [ qw/ available_languages to_string        to_ordinal        / ],
   long      => [ qw/ available_languages number_to_string number_to_ordinal / ],
);

@EXPORT_TAGS{ qw/ std std2 / } = @EXPORT_TAGS{ qw/ standard standard2 / };

my %LMAP;
my $DEFAULT    = 'EN';
my $USE_LOCALE = 0;
# blacklist non-language modules
my %NOT_LANG   = map { $_ => 1 } qw(
   Any
   Base
   Conlang
   Slavic
);

_probe(); # fetch/examine/compile all available modules

sub import {
   my($class, @args) = @_;
   my @exports;

   foreach my $thing ( @args ) {
      if ( lc $thing eq '+locale' ) { $USE_LOCALE = 1; next; }
      if ( lc $thing eq '-locale' ) { $USE_LOCALE = 0; next; }
      push @exports, $thing;
   }

   return $class->export_to_level( 1, $class, @exports );
}

sub to_string  {
   my @args = @_;
   return _to( string  => @args )
}

sub to_ordinal {
   my @args = @_;
   return _to( ordinal => @args )
}

sub available {
   my @ids = sort keys %LMAP;
   return @ids;
}

sub language_handler {
   my $lang = shift             || return;
   my $h    = $LMAP{ uc $lang } || return;
   return $h->{class};
}

# -- PRIVATE -- #

sub _to {
   my $type   = shift || croak 'No type specified';
   my $n      = shift;
   my $lang   = shift || _get_lang();
      $lang   = uc $lang;
      $lang   = _get_lang($lang) if $lang eq 'LOCALE';
   if ( ($lang eq 'LOCALE' || $USE_LOCALE) && ! exists $LMAP{ $lang } ) {
      _w("Locale language ($lang) is not available. "
        ."Falling back to default language ($DEFAULT)");
      $lang = $DEFAULT; # prevent die()ing from an absent driver
   }
   my $struct = $LMAP{ $lang } || croak "Language ($lang) is not available";
   return $struct->{ $type }->( $n );
}

sub _get_lang {
   my $lang;
   my $locale = shift;
   $lang = _get_lang_from_locale() if $locale || $USE_LOCALE;
   $lang = $DEFAULT if ! $lang;
   return uc $lang;
}

sub _get_lang_from_locale {
   require I18N::LangTags::Detect;
   my @user_wants = I18N::LangTags::Detect::detect();
   my $lang = $user_wants[0] || return;
   ($lang,undef) = split m{\-}xms, $lang; # tr-tr
   return $lang;
}

sub _is_silent { return defined &SILENT && SILENT() }

sub _dummy_ordinal { return shift }
sub _dummy_string  { return shift }
sub _dummy_oo      {
   my $class = shift;
   my $type  = shift;
   return $type && ! $class->can('parse')
         ? sub { $class->new->$type( shift ) }
         : sub { $class->new->parse( shift ) }
         ;
}

sub _probe {
   my @compile;
   foreach my $module ( _probe_inc() ) {
      my $class = $module->[LCLASS];

      (my $inc = $class) =~ s{::}{/}xmsg;
      $inc .= q{.pm};

      if ( ! $INC{ $inc } ) {
         my $file = File::Spec->catfile( split m{::}xms, $class ) . '.pm';
         eval {
            require $file;
            $class->import;
            1;
         } or do {
            # some modules need attention
            _probe_error($@, $class);
            next;
         };
         $INC{ $inc } = $INC{ $file };
      }

      push @compile, $module;
   }
   _compile( \@compile );
   return 1;
}

sub _probe_error {
   my($e, $class) = @_;
   if ( $e =~ RE_LEGACY_PERL ) { # JA -> 5.6.2
      return _w( _eprobe( $class, $1, $2 ) );
   }
   croak("An error occurred while including sub modules: $e");
}

sub _probe_inc {
   require Symbol;
   my @classes;
   foreach my $inc ( @INC ) {
      my $path = File::Spec->catfile( $inc, 'Lingua' );
      next if ! -d $path;
      my $DIRH = Symbol::gensym();
      opendir $DIRH, $path or croak "opendir($path): $!";
      while ( my $dir = readdir $DIRH ) {
         next if $dir =~ m{ \A [.] }xms || $NOT_LANG{ $dir };
         ($dir) = $dir =~ m{([a-z0-9_]+)}xmsi or next; # untaint
         my @rs = _probe_exists($path, $dir);
         next if ! @rs; # bogus
         foreach my $e ( @rs ) {
            my($file, $type) = @{ $e };
            push @classes, [ join(q{::}, 'Lingua', $dir, $type), $file, $dir ];
         }
      }
      closedir $DIRH;
   }

   return @classes;
}

sub _probe_exists {
   my($path, $dir) = @_;
   my @results;
   foreach my $possibility ( qw[ Numbers Num2Word Nums2Words Numeros Nums2Ords ] ) {
      my $file = File::Spec->catfile( $path, $dir, $possibility . '.pm' );
      next if ! -e $file || -d _;
      push @results, [ $file, $possibility ];
   }
   return @results;
}

sub _w {
   return _is_silent() ? 1 : do { warn "@_\n"; 1 };
}

sub _eprobe {
   my @args = @_;
   my $tmp  = @args > 2 ? q{%s requires a newer (%s) perl binary. You have %s}
            :             q{%s requires a newer perl binary. You have %s}
            ;
   return sprintf $tmp, @args;
}

sub _merge_into_numbers {
   my($id, $lang ) = @_;
   my $e       = delete $lang->{ $id };
   my %test    = map { @{ $_ } } @{ $e };
   my $words   = delete $test{'Lingua::' . $id . '::Nums2Words' };
   my $ords    = delete $test{'Lingua::' . $id . '::Nums2Ords' };
   my $numbers = delete $test{'Lingua::' . $id . '::Numbers' };

   if ( ! $numbers && ( $ords || $words ) ) {
      my $file  = sprintf 'Lingua/%s/Numbers.pm', $id;
      my $c     = sprintf 'Lingua::%s::Numbers', $id;
      $INC{ $file } ||= 'Fake placeholder module';
      my $n     = $c . '::num2' . lc $id;
      my $v     = $c . '::VERSION';
      my $o     = $n . '_ordinal';
      my $f     = $c . '::_faked_by_lingua_any_numbers';
      my $card  = 'Lingua::' . $id . '::Nums2Words::num2word';
      my $ord   = 'Lingua::' . $id . '::Nums2Ords::num2ord';
      $lang->{ $id } = [ $c, $INC{ $file } ];

      no strict qw( refs ); ## no critic (ProhibitProlongedStrictureOverride)
      *{ $n } =   \&{ $card    } if $words && ! $c->can('num2tr');
      *{ $o } =   \&{ $ord     } if $ords  && ! $c->can('num2ord');
      *{ $v } = sub { $VERSION } if           ! $c->can('VERSION');
      *{ $f } = sub { return { words => $words, ords => $ords } };

      return;
   }

   $lang->{ $id } = $e; # restore

   return;
}

sub _compile {
   my $classes = shift;
   my %lang;
   foreach my $e ( @{ $classes } ) {
      my($class, $file, $id) = @{ $e };
      $lang{ $id } = [] if ! defined $lang{ $id };
      push @{ $lang{ $id } }, [ $class, $file ];
   }

   foreach my $id ( keys %lang ) {
      if ( $id eq 'PT' ) {
         _merge_into_numbers( $id, \%lang );
         next;
      }
      my @choices = @{ $lang{ $id } };
      my $numbers;
      foreach my $c ( @choices ) {
         my($class, $file) = @{ $c };
         $numbers = $c if $class =~ m{::Numbers\z}xms;
      }
      $lang{ $id } = $numbers ? [ @{ $numbers} ] : shift @choices;
   }

   foreach my $l ( keys %lang ) {
      my $e = $lang{ $l };
      my $c = $e->[0];
      $LMAP{ uc $l } = {
         string  => _test_cardinal($c, $l),
         ordinal => _test_ordinal( $c, $l),
         class   => $c,
      };
   }

   return;
}

sub _test_cardinal {
   my($c, $l) = @_;
   $l = lc $l;
   no strict qw(refs);
   my %s = %{ "${c}::" };
   my $n = $s{new};
   return
        $s{"num2${l}"}         ? \&{"${c}::num2${l}"          }
      : $s{"number_to_${l}"}   ? \&{"${c}::number_to_${l}"    }
      : $s{'nums2words'}       ? \&{"${c}::nums2words"        }
      : $s{'num2word'}         ? \&{"${c}::num2word"          }
      : $s{cardinal2alpha}     ? \&{"${c}::cardinal2alpha"    }
      : $s{cardinal} && $n     ? _dummy_oo( $c, 'cardinal' )
      : $s{parse}              ? _dummy_oo( $c )
      : $s{"num2${l}_cardinal"}? $n ? _dummy_oo( $c, "num2${l}_cardinal" )
                                    :       \&{"${c}::num2${l}_cardinal" }
      :                          \&_dummy_string
      ;
}

sub _test_ordinal {
   my($c, $l) = @_;
   $l = lc $l;
   no strict qw(refs);
   my %s = %{ "${c}::" };
   my $n = $s{new} && ! _like_en( $c );
   return
     $s{"ordinate_to_${l}"}   ? \&{"${c}::ordinate_to_${l}"}
   : $s{ordinal2alpha}        ? \&{"${c}::ordinal2alpha"   }
   : $s{ordinal} && $n        ? _dummy_oo( $c, 'ordinal' )
   : $s{"num2${l}_ordinal"}   ? $n ? _dummy_oo( $c, "num2${l}_ordinal" )
                                   :      \&{ "${c}::num2${l}_ordinal" }
   :                          \&_dummy_ordinal
   ;
}

sub _like_en {
   my $c  = shift;
   my $rv = $c->isa('Lingua::EN::Numbers')
            || $c->isa('Lingua::JA::Numbers')
            || $c->isa('Lingua::TR::Numbers')
            ;
   return $rv;
}

1;

__END__