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

$VERSION = '0.46';

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__

=pod

=head1 NAME

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

=head1 SYNOPSIS

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

or test all available languages

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

=head1 DESCRIPTION

This document describes version C<0.46> of C<Lingua::Any::Numbers>
released on C<5 July 2016>.

The most popular C<Lingua> modules are seem to be the ones that convert
numbers into words. These kind of modules exist for a lot of languages.
However, there is no standard interface defined for them. Most
of the modules' interfaces are completely different and some do not implement
the ordinal conversion at all. C<Lingua::Any::Numbers> tries to create a common
interface to call these different modules. And if a module has a known
interface, but does not implement the required function/method then the
number itself is returned instead of dying. It is also possible to
take advantage of the automatic locale detection if you install all the
supported modules listed in the L</SEE ALSO> section.

L<Task::Lingua::Any::Numbers> can be installed to get all the available modules
related to L<Lingua::Any::Numbers> on C<CPAN>.

=head1 IMPORT PARAMETERS

All functions and aliases can be imported individually, 
but there are some predefined import tags:

   :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()

=head1 C<IMPORT PRAGMAS>

Some parameters enable/disable module features. C<+> is prefixed to enable
these options. C<Pragmas> have global effect (i.e.: not lexical), they can not
be disabled afterwards.

=head2 locale

Use the language from system locale:

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

However, the second parameter to the functions take precedence. If the language
parameter is used, C<locale> C<pragma> will be discarded.

Install all the C<Lingua::*::Numbers> modules to take advantage of the
locale C<pragma>.

It is also possible to enable C<locale> usage through the functions.
See L</FUNCTIONS>.

C<locale> is implemented with L<I18N::LangTags::Detect>.

=head1 FUNCTIONS

All language parameters (C<LANG>) have a default value: C<EN>. If it is set to
C<LOCALE>, then the language from the system C<locale> will be used
(if available).

=head2 to_string NUMBER [, LANG ]

Aliases:

=over 4

=item C<num2str>

=item number_to_string

=back

=head2 to_ordinal NUMBER [, LANG ]

Aliases: 

=over 4

=item C<num2ord>

=item number_to_ordinal

=back

=head2 available

Returns a list of available language ids.

Aliases:

=over 4

=item available_langs

=item available_languages

=back

=head2 language_handler

Returns the name of the language handler class if you pass a language id and
a class for that language id is loaded. Returns C<undef> otherwise.

This function can not be imported. Use a fully qualified name to call:

   my $sv = language_handler('SV');

=head1 DEBUGGING

=head2 SILENT

If you define a sub named C<Lingua::Any::Numbers::SILENT> and return
a true value from that, then the module will not generate any warnings
when it faces some recoverable errors.

C<Lingua::Any::Numbers::SILENT> is not defined by default.

=head1 CAVEATS

=over 4

=item *

Some modules return C<UTF8>, while others return arbitrary C<encodings>.
C<ascii> is all right, but others will be problematic. A future release can
convert all to C<UTF8>.

=item *

All available modules will immediately be searched and loaded into
memory (before using any function).

=item *

No language module (except C<Lingua::EN::Numbers>) is required by 
L<Lingua::Any::Numbers>, so you'll need to install the other 
modules manually.

=back

=head1 SEE ALSO

   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

You can just install L<Task::Lingua::Any::Numbers> to get all modules above.

=head2 BOGUS MODULES

Some modules on C<CPAN> suggest to convert numbers into words by their
names, but they do something different instead. Here is a list of
the bogus modules:

   Lingua::FA::Number

=head1 AUTHOR

Burak Gursoy <burak@cpan.org>.

=head1 COPYRIGHT

Copyright 2007 - 2016 Burak Gursoy. All rights reserved.

=head1 LICENSE

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.24.0 or,
at your option, any later version of Perl 5 you may have available.
=cut
