File Coverage

blib/lib/Lingua/SPA/Numeros.pm

Criterion	Covered	Total	%
statement	220	226	97.3
branch	129	142	90.8
condition	26	28	92.8
subroutine	27	27	100.0
pod	17	17	100.0
total	419	440	95.2

# For Emacs: -*- mode:cperl; eval: (folding-mode 1); coding:utf-8; -*-
#
# Jose Luis Rey Barreira (c) 2001-2009
# Copyright (c) PetaMem, s.r.o. 2010-present
#

package Lingua::SPA::Numeros;
# ABSTRACT: Number 2 word conversion in SPA.

# {{{ use block

use 5.16.0;
use utf8;

use Carp;

# }}}
# {{{ var block
our $VERSION = '0.2603230';


our @EXPORT_OK = qw( $MALE $FEMALE $NEUTRAL $MALE $FEMALE $NEUTRAL);

no warnings; ## no critic
our $MALE    => 'o';
our $FEMALE  => 'a';
our $NEUTRAL => '';
use warnings;

use fields qw/ ACENTOS MAYUSCULAS UNMIL HTML DECIMAL SEPARADORES GENERO
    POSITIVO NEGATIVO FORMATO /;

my %opt_alias = qw(
    ACCENTS     ACENTOS
    UPPERCASE   MAYUSCULAS
    SEPARATORS  SEPARADORES
    GENDER      GENERO
    POSITIVE    POSITIVO
    NEGATIVE    NEGATIVO
    FORMAT      FORMATO );

my %new_defaults = (
    ACENTOS     => 1,
    MAYUSCULAS  => 0,
    UNMIL       => 1,
    HTML        => 0,
    DECIMAL     => '.',
    SEPARADORES => '_',
    GENERO      => $MALE,
    POSITIVO    => '',
    NEGATIVO    => 'menos',
    FORMATO     => 'con %02d ctms.',
);

# }}}
# {{{ new

sub new {
    my $self = shift;
    unless ( ref $self ) {
        $self = fields::new($self);
    }

    #%$self = (%new_defaults, @_);
    {    # Compatibility conversion of SEXO into GENERO
        my %opts = ( %new_defaults, @_ );
        if ( $opts{'SEXO'} ) {
            $opts{'GENERO'} = $opts{'SEXO'};
            delete $opts{'SEXO'};
        }
        %$self = %opts
    }
    return $self;
}

# }}}
# {{{ cardinal

sub cardinal {
    my $self = shift;
    my $num  = shift;
    my ( $sgn, $ent, $frc, $exp ) = parse_num( $num, $self->{'DECIMAL'}, $self->{'SEPARADORES'} );
    my @words = cardinal_simple( $ent, $exp, $self->{'UNMIL'}, $self->{'GENERO'} );
    if (@words) {
        unshift @words, $self->{'NEGATIVO'} if $sgn < 0 and $self->{'NEGATIVO'};
        unshift @words, $self->{'POSITIVO'} if $sgn > 0 and $self->{'POSITIVO'};
        return $self->retval( join( " ", @words ) );
    }
    else {
        return $self->retval('cero');
    }
}

# }}}
# {{{ real

sub real {
    my $self = shift;
    my ( $num, $genf, $genm ) = @_;
    my ( $sgn, $ent, $frc, $exp ) = parse_num( $num, $self->{'DECIMAL'}, $self->{'SEPARADORES'} );

    my $gen = $self->{'GENERO'};
    $genf = $gen  unless defined $genf;
    $genm = $genf unless defined $genm;

    # Convertir la parte entera ajustando el sexo
    #my @words = cardinal_simple($ent, $exp, $self->{'UNMIL'}, $gen);

    # Traducir la parte decimal de acuerdo al formato
    for ( $self->{'FORMATO'} ) {
        /%([0-9]*)s/ && do {

            # Textual, se traduce según el genero
            $frc = substr( '0' x $exp . $frc, 0, $1 ) if $1;
            $frc = join( " ", fraccion_simple( $frc, $exp, $self->{'UNMIL'}, $genf, $genm ) );
            $frc = $frc ? sprintf( $self->{'FORMATO'}, $frc ) : '';
            last;
        };
        /%([0-9]*)d/ && do {

            # Numérico, se da formato a los dígitos
            $frc = substr( '0' x $exp . $frc, 0, $1 );
            $frc = sprintf( $self->{'FORMATO'}, $frc );
            last;
        };
        do {

            # Sin formato, se ignoran los decimales
            $frc = '';
            last;
        };
    }
    if ($ent) {
        $ent = $self->cardinal( ( $sgn < 0 ? '-' : '+' ) . $ent );
    }
    else {
        $ent = 'cero';
    }
    $ent .= ' ' . $frc if $ent and $frc;
    return $self->retval($ent);
}

# }}}
# {{{ ordinal

sub ordinal {
    my $self = shift;
    my $num  = shift;
    my ( $sgn, $ent, $frc, $exp ) = parse_num( $num, $self->{'DECIMAL'}, $self->{'SEPARADORES'} );

    croak "Ordinal negativo"     if $sgn < 0;
    carp "Ordinal con decimales" if $frc;

    if ( $ent =~ /^0*$/ ) {
        carp "Ordinal cero";
        return '';
    }

    my $text = join( " ", ordinal_simple( $ent, $exp, $self->{'GENERO'} ) );

    return $self->retval($text);
}

# }}}
# {{{ Build the accessors

{
    my @a = @_;
    my %names = ( ( map { $_ => $_ } keys %new_defaults ), %opt_alias );
    while ( my ( $opt, $alias ) = each %names ) {
        $opt = lc $opt;
        no strict 'refs'; ## no critic
        *$opt = sub {
            my $self = shift;
            return $self->{$alias} unless @a;
            $self->{$alias} = shift @a;
            return $self;
            }
    }
}

# }}}

#####################################################################
#
# Soporte para números CARDINALES
#
####################################################################
# {{{ variable declarations II

my @cardinal_30 = qw/ cero un dos tres cuatro cinco seis siete ocho nueve diez
    once doce trece catorce quince dieciséis diecisiete dieciocho diecinueve
    veinte veintiun veintidós veintitrés veinticuatro veinticinco veintiséis
    veintisiete veintiocho veintinueve /;

my @cardinal_dec = qw/
    0 1 2 treinta cuarenta cincuenta sesenta setenta ochenta noventa /;

my @cardinal_centenas = (
    "", qw/
        ciento doscientos trescientos cuatrocientos quinientos
        seiscientos setecientos ochocientos novecientos /
);

my @cardinal_megas = (
    "", qw/ m b tr cuatr quint sext sept oct non dec undec
        dudec tredec cuatordec quindec sexdec sepdec octodec novendec vigint /
);

my $MAX_DIGITS = 6 * @cardinal_megas;

# }}}
# {{{ cardinal_e2

sub cardinal_e2 {
    my ( $n, $nn ) = @_;

    return if $n == 0;
    do { push @$nn, $cardinal_30[$n]; return } if $n < 30;
    $n =~ /^(.)(.)$/;
    push @$nn, $cardinal_30[$2], "y" if $2;
    push @$nn, $cardinal_dec[$1];

    return;
}

# }}}
# {{{ cardinal_e3

sub cardinal_e3 {
    my ( $n, $nn ) = @_;

    return if $n == 0;
    $n == 100 and do { push @$nn, "cien"; return };
    cardinal_e2( $n % 100, $nn );
    $n >= 100 and push @$nn, $cardinal_centenas[ int( $n / 100 ) ];

    return;
}

# }}}
# {{{ cardinal_e6

sub cardinal_e6 {
    my ( $n, $nn, $mag, $un_mil, $postfix ) = @_;

    return if $n == 0;
    push @$nn, $cardinal_megas[$mag] . $postfix->[ $n == 1 ] if $mag;
    cardinal_e3( $n % 1000, $nn );
    my $n3 = int( $n / 1000 );
    if ($n3) {
        push @$nn, "mil";
        cardinal_e3( $n3, $nn ) if $n3 != 1 or $un_mil;
    }

    return;
}

# }}}
# {{{ cardinal_generic

sub cardinal_generic {
    my ( $n, $exp, $fmag, $gen ) = @_;
    $gen //= '';

    $n =~ s/^0*//;    # eliminar ceros a la izquierda
    return () unless $n;
    croak("Fuera de rango") if length($n) + $exp > $MAX_DIGITS;
    $n .= "0" x ( $exp % 6 );    # agregar ceros a la derecha
    my $mag   = int( $exp / 6 );
    my @group = ();
    $fmag->( $1, \@group, $mag++ ) while $n =~ s/(.{1,6})$//x;
    $group[0] .= $gen if $group[0] =~ /un$/;
    return reverse @group;
}

# }}}
# {{{ cardinal_simple

sub cardinal_simple {
    my ( $n, $exp, $un_mil, $gen ) = @_;

    $un_mil = $un_mil ? 1 : 0;
    $gen = $NEUTRAL unless $gen;
    my $format = sub {
        cardinal_e6( $_[0], $_[1], $_[2], $un_mil, [ 'illones', 'illón' ] );
    };
    return cardinal_generic( $n, $exp, $format, $gen );
}

# }}}
# {{{ fraccion_mag_prefix

sub fraccion_mag_prefix {
    my ( $mag, $gp ) = @_;

    return "" unless $mag;
    return "décim" . $gp    if $mag == 1;
    return "centésim" . $gp if $mag == 2;
    my $format = sub {
        cardinal_e6( $_[0], $_[1], $_[2], 0, [ 'illon', 'illon' ] );
    };
    my @name = cardinal_generic( 1, $mag, $format, "" );
    shift @name unless $mag % 6;
    return join( "", @name, "ésim", $gp );
}

# }}}
# {{{ fraccion_simple

sub fraccion_simple {
    my ( $n, $exp, $un_mil, $gen, $ngen ) = @_;

    $n =~ s/0*$//;    # eliminar 0 a la derecha
    return () if $n == 0;
    $ngen = $gen unless defined $ngen;
    $exp = -$exp + length $n;    # adjust exponent
    croak("Fuera de rango") if $exp > $MAX_DIGITS;
    $gen .= "s" unless $n =~ /^0*1$/;
    return ( cardinal_simple( $n, 0, $un_mil, $ngen ), fraccion_mag_prefix( $exp, $gen ) );
}

# }}}
#####################################################################
#
# Soporte para números ORDINALES
#
####################################################################
# {{{ variable declarations III

my @ordinal_13 = (
    '', qw/ primer_ segund_ tercer_ cuart_ quint_ sext_
        séptim_ octav_ noven_ décim_ undécim_ duodécim_ /
);

my @ordinal_dec = qw/ 0 1 vi tri cuadra quicua sexa septua octo nona /;

my @ordinal_cen = qw/ 0 c duoc tric cuadring quing sexc septig octing noning /;

# }}}
# {{{ ordinal_e2

sub ordinal_e2 {
    my ( $n, $nn ) = @_;

    return if $n == 0;
    if ( $n < 13 ) {
        push @$nn, $ordinal_13[$n];
        return;
    }
    $n =~ /^(.)(.)$/;
    my $lo = $ordinal_13[$2];
    if ( $1 <= 2 ) {
        my $name = $2
            ? ( $1 == 1 ? 'decimo' : 'vigesimo' )
            : ( $1 == 1 ? 'décim_' : 'vigésim_' );
        $name =~ s/o$// if $2 == 8;    # special case vowels colapsed
        push @$nn, $name . $lo;
        return;
    }
    push @$nn, $lo if $2;
    push @$nn, $ordinal_dec[$1] . 'gésim_';
    return;
}

# }}}
# {{{ ordinal_e3

sub ordinal_e3 {
    my ( $n, $nn ) = @_;

    return if $n == 0;
    ordinal_e2( $n % 100, $nn );
    push @$nn, $ordinal_cen[ int( $n / 100 ) ] . 'entésim_' if $n > 99;

    return;
}

# }}}
# {{{ ordinal_e6

sub ordinal_e6 {
    my ( $n, $nn, $mag ) = @_;

    return if $n == 0;
    push @$nn, $cardinal_megas[$mag] . 'illonésim_' if $mag;
    ordinal_e3( $n % 1000, $nn );
    my $n3 = int( $n / 1000 );
    if ($n3) {
        if ( $n3 > 1 ) {
            my $pos = @$nn;    # keep pos to adjust number
            cardinal_e3( $n3, $nn );    # this is not a typo, its cardinal
            $nn->[$pos] .= 'milésim_';
        }
        else {
            push @$nn, "milésim_";
        }
    }

    return;
}

# }}}
# {{{ ordinal_simple

sub ordinal_simple {
    my ( $n, $exp, $gen ) = @_;

    $n =~ s/^0*//;    # eliminar ceros a la izquierda
    return () unless $n;
    croak("Fuera de rango") if length($n) + $exp > $MAX_DIGITS;
    $n .= "0" x ( $exp % 6 );    # agregar ceros a la derecha
    my $mag = int( $exp / 6 );

    my @group = ();
    if ( $mag == 0 ) {
        $n =~ s/(.{1,6})$//x;
        ordinal_e6( $1, \@group, $mag++ );
    }

    while ( $n =~ s/(.{1,6})$//x ) {
        if ( $1 == 0 ) {
            $mag++;
            next;
        }
        my $words = [];
        if ( $1 == 1 ) {
            push @$words, '';
        }
        else {
            cardinal_e6( $1, $words, 0, 0, [] );
        }
        $words->[0] .= $cardinal_megas[ $mag++ ] . 'illonésim_';
        push @group, @$words;
    }

    unless ($gen) {
        $group[0] =~ s/r_$/r/;    # Ajustar neutros en 1er, 3er, etc.
        $gen = $MALE;
    }
    s/_/$gen/g for @group;
    return reverse @group;
}

# }}}
# {{{ parse_num

sub parse_num {
    my ( $num, $dec, $sep ) = @_;

    # Eliminar blancos y separadores
    $num =~ s/[\s\Q$sep\E]//g;
    $dec = '\\' . $dec if $dec eq '.';
    my ( $sgn, $int, $frc, $exp ) = $num =~ /^
        ([+-]?) (?= \d | $dec\d )   # signo
        (\d*)                       # parte entera
        (?: $dec (\d*) )?           # parte decimal
        (?: [Ee] ([+-]?\d+) )?      # exponente
        $/x or croak("Error de sintaxis");

    $sgn = $sgn eq '-' ? -1 : 1;    # ajustar signo
    return ( $sgn, $int || 0, $frc || 0, $exp ) unless $exp ||= 0;

    $int ||= '';
    $frc ||= '';

    # reducir la magnitud del exponente
    if ( $exp > 0 ) {
        if ( $exp > length $frc ) {
            $exp -= length $frc;
            $int .= $frc;
            $frc = '';
        }
        else {
            $int .= substr( $frc, 0, $exp );
            $frc = substr( $frc, $exp );
            $exp = 0;
        }
    }
    else {
        if ( -$exp > length $int ) {
            $exp += length $int;
            $frc = $int . $frc;
            $int = '';
        }
        else {
            $frc = substr( $int, $exp + length $int ) . $frc;
            $int = substr( $int, 0, $exp + length $int );
            $exp = 0;
        }
    }
    return ( $sgn, $int || 0, $frc || 0, $exp );
}

# }}}
# {{{ retval

sub retval {
    my $self = shift;
    my $rv   = shift;
    if ( $self->{ACENTOS} ) {
        if ( $self->{HTML} ) {
            $rv =~ s/([áéíóú])/&$1acute;/g;
            $rv =~ tr/áéíóú/aeiou/;
        }
    }
    else {
        $rv =~ tr/áéíóú/aeiou/;
    }
    return $self->{MAYUSCULAS} ? uc $rv : $rv;
}

# }}}

1;
__END__