Lingua::Any::Numbers - Converts numbers into (any available language) string.

   use Lingua::Any::Numbers qw(:std);
   printf "Available languages are: %s\n", join( ", ", available );
   printf "%s\n", to_string(  45 );
   printf "%s\n", to_ordinal( 45 );

   use Lingua::Any::Numbers qw(:std);
   foreach my $lang ( available ) {
      printf "%s\n", to_string(  45, $lang );
      printf "%s\n", to_ordinal( 45, $lang );
   }

   :all        Import everything (including aliases)
   :standard   available(), to_string(), to_ordinal().
   :std        Alias to :standard
   :standard2  available_languages(), to_string(), to_ordinal()
   :std2       Alias to :standard2
   :long       available_languages(), number_to_string(), number_to_ordinal()

   use Lingua::Any::Numbers qw(:std +locale);
   print to_string(81); # will use locale

   my $sv = language_handler('SV');

   Lingua::AF::Numbers
   Lingua::BG::Numbers
   Lingua::EN::Numbers
   Lingua::EU::Numbers
   Lingua::FR::Numbers
   Lingua::HU::Numbers
   Lingua::IT::Numbers
   Lingua::JA::Numbers
   Lingua::NL::Numbers
   Lingua::PL::Numbers
   Lingua::SV::Numbers
   Lingua::TR::Numbers
   Lingua::ZH::Numbers

   Lingua::CS::Num2Word
   Lingua::DE::Num2Word
   Lingua::ES::Numeros
   Lingua::ID::Nums2Words
   Lingua::NO::Num2Word
   Lingua::PT::Nums2Word

   Lingua::FA::Number

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

$VERSION = '0.43';

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 PREHISTORIC    =>  $] < 5.006;
use constant LEGACY         => ($] < 5.008) && ! PREHISTORIC;

use constant RE_LEGACY_PERL => qr{
      Perl \s+ (.+?) \s+ required
      --this \s+ is \s+ only \s+ (.+?),
      \s+ stopped
}xmsi;
use constant RE_LEGACY_VSTR => qr{
      syntax \s+ error \s+ at \s+ (.+?)
      \s+ line \s+ (?:.+?),
      \s+ near \s+ "use \s+ (.+?)"
}xmsi;
use constant RE_UTF8_FILE => qr{ Unrecognized \s+ character \s+ \\ \d+ \s+ }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;

_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 {
   return keys %LMAP;
}

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];
      # PL driver is problematic under 5.5.4
      if ( PREHISTORIC && $class->isa('Lingua::PL::Numbers') ) {
         _w("Disabling $class under legacy perl ($])") && next;
      }

      (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 ) );
   }

   if ( $e =~ RE_LEGACY_VSTR ) { # HU -> 5.005_04
      return _w( _eprobe( $class, $2, $] ) );
   }

   if ( $e =~ RE_UTF8_FILE ) { # JA -> 5.005_04
      return _w( _eprobe( $class, $] ) );
   }

   return 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 || $dir eq 'Any' || $dir eq 'Slavic';
         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 );
      *{ $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__