File Coverage

blib/lib/Locales.pm

Criterion	Covered	Total	%
statement	530	579	91.5
branch	267	354	75.4
condition	126	206	61.1
subroutine	68	68	100.0
pod	55	55	100.0
total	1046	1262	82.8

package Locales;

use strict;
use warnings;

use Module::Want 0.6;

$Locales::VERSION      = '0.34';    # change in POD
$Locales::cldr_version = '2.0';     # change in POD

$Locales::_UNICODE_STRINGS = 0;

sub import {
    my ( $c, %opt ) = @_;
    if ( exists $opt{unicode} ) {
        $Locales::_UNICODE_STRINGS = $opt{unicode};
    }
    return;
}

#### class methods ####

my %singleton_stash;

sub get_cldr_version {
    return $Locales::cldr_version;
}

sub new {
    my ( $class, $tag ) = @_;
    $tag = normalize_tag($tag) || 'en';

    if ( !exists $singleton_stash{$tag} ) {

        my $locale = {
            'locale' => $tag,
        };

        if ( my $soft = tag_is_soft_locale($tag) ) {

            # return if exists $conf->{'soft_locales'} && !$conf->{'soft_locales'};
            $locale->{'soft_locale_fallback'} = $soft;
            $tag = $soft;
        }

        my $inc_class = ref($class) ? ref($class) : $class;
        $inc_class =~ s{(?:\:\:|\')}{/}g;    # per Module::Want::get_inc_key()

        have_mod("$class\::DB::Language::$tag")  || return;
        have_mod("$class\::DB::Territory::$tag") || return;

        my ( $language, $territory ) = split_tag( $locale->{'locale'} );

        no strict 'refs';                    ## no critic

        $locale->{'language'}      = $language;
        $locale->{'language_data'} = {
            'VERSION'      => \${"$class\::DB::Language::$tag\::VERSION"},
            'cldr_version' => \${"$class\::DB::Language::$tag\::cldr_version"},
            'misc_info'    => \%{"$class\::DB::Language::$tag\::misc_info"},
            'code_to_name' => \%{"$class\::DB::Language::$tag\::code_to_name"},
            'name_to_code' => \%{"$class\::DB::Language::$tag\::name_to_code"},
        };

        $locale->{'territory'}      = $territory;
        $locale->{'territory_data'} = {
            'VERSION'      => \${"$class\::DB::Territory::$tag\::VERSION"},
            'cldr_version' => \${"$class\::DB::Territory::$tag\::cldr_version"},
            'code_to_name' => \%{"$class\::DB::Territory::$tag\::code_to_name"},
            'name_to_code' => \%{"$class\::DB::Territory::$tag\::name_to_code"},
        };

        $locale->{'misc'}{'list_quote_mode'} = 'none';

        $singleton_stash{$tag} = bless $locale, $class;
    }

    return $singleton_stash{$tag};
}

#### object methods ####

sub get_soft_locale_fallback {
    return $_[0]->{'soft_locale_fallback'} if $_[0]->{'soft_locale_fallback'};
    return;
}

sub get_locale { shift->{'locale'} }

sub get_territory { shift->{'territory'} }

sub get_language { shift->{'language'} }

sub get_native_language_from_code {
    my ( $self, $code, $always_return ) = @_;

    my $class = ref($self) ? ref($self) : $self;
    if ( !exists $self->{'native_data'} ) {
        have_mod("$class\::DB::Native") || return;
        no strict 'refs';    ## no critic
        $self->{'native_data'} = {
            'VERSION'      => \${"$class\::DB::Native::VERSION"},
            'cldr_version' => \${"$class\::DB::Native::cldr_version"},
            'code_to_name' => \%{"$class\::DB::Native::code_to_name"},
        };
    }

    $code ||= $self->{'locale'};
    $code = normalize_tag($code);
    return if !defined $code;

    $always_return ||= 1 if $code eq $self->get_locale() && $self->get_soft_locale_fallback();    # force $always_return under soft locale objects
    $always_return ||= 0;

    if ( exists $self->{'native_data'}{'code_to_name'}{$code} ) {
        return $self->{'native_data'}{'code_to_name'}{$code};
    }
    elsif ($always_return) {
        my ( $l, $t ) = split_tag($code);
        my $ln = $self->{'native_data'}{'code_to_name'}{$l};
        my $tn = defined $t ? $self->{'territory_data'}{'code_to_name'}{$t} : '';

        return $code if !$ln && !$tn;

        if ( defined $t ) {
            my $tmp = Locales->new($l);    # if we even get to this point: this is a singleton so it is cheap
            if ($tmp) {
                if ( $tmp->get_territory_from_code($t) ) {
                    $tn = $tmp->get_territory_from_code($t);
                }
            }
        }

        $ln ||= $l;
        $tn ||= $t;

        my $string = get_locale_display_pattern_from_code_fast($code) || $self->{'language_data'}{'misc_info'}{'cldr_formats'}{'locale'} || '{0} ({1})';
        $string =~ s/\{0\}/$ln/g;
        $string =~ s/\{1\}/$tn/g;

        return $string;
    }
    return;
}

sub numf {
    my ( $self, $always_return ) = @_;
    my $class = ref($self) ? ref($self) : $self;
    $always_return ||= 0;
    $self->{'language_data'}{'misc_info'}{'cldr_formats'}{'_decimal_format_group'}   = '' if !defined $self->{'language_data'}{'misc_info'}{'cldr_formats'}{'_decimal_format_group'};
    $self->{'language_data'}{'misc_info'}{'cldr_formats'}{'_decimal_format_decimal'} = '' if !defined $self->{'language_data'}{'misc_info'}{'cldr_formats'}{'_decimal_format_decimal'};

    if ( !$self->{'language_data'}{'misc_info'}{'cldr_formats'}{'_decimal_format_group'} || !$self->{'language_data'}{'misc_info'}{'cldr_formats'}{'_decimal_format_decimal'} ) {
        if ($always_return) {
            if ( $self->{'language_data'}{'misc_info'}{'cldr_formats'}{'_decimal_format_group'} || !$self->{'language_data'}{'misc_info'}{'cldr_formats'}{'_decimal_format_decimal'} ) {
                return 2 if $self->{'language_data'}{'misc_info'}{'cldr_formats'}{'_decimal_format_group'} eq '.';
                return 1;
            }
            elsif ( !$self->{'language_data'}{'misc_info'}{'cldr_formats'}{'_decimal_format_group'} || $self->{'language_data'}{'misc_info'}{'cldr_formats'}{'_decimal_format_decimal'} ) {
                return 2 if $self->{'language_data'}{'misc_info'}{'cldr_formats'}{'_decimal_format_decimal'} eq ',';
                return 1;
            }
            else {
                return 1;
            }
        }
    }

    if ( $self->{'language_data'}{'misc_info'}{'cldr_formats'}{'decimal'} eq "\#\,\#\#0\.\#\#\#" ) {
        if ( $self->{'language_data'}{'misc_info'}{'cldr_formats'}{'_decimal_format_group'} eq ',' && $self->{'language_data'}{'misc_info'}{'cldr_formats'}{'_decimal_format_decimal'} eq '.' ) {
            return 1;
        }
        elsif ( $self->{'language_data'}{'misc_info'}{'cldr_formats'}{'_decimal_format_group'} eq '.' && $self->{'language_data'}{'misc_info'}{'cldr_formats'}{'_decimal_format_decimal'} eq ',' ) {
            return 2;
        }
    }
    elsif ( $always_return && $self->{'language_data'}{'misc_info'}{'cldr_formats'}{'_decimal_format_group'} && $self->{'language_data'}{'misc_info'}{'cldr_formats'}{'_decimal_format_decimal'} ) {
        return 2 if $self->{'language_data'}{'misc_info'}{'cldr_formats'}{'_decimal_format_decimal'} eq ',';
        return 2 if $self->{'language_data'}{'misc_info'}{'cldr_formats'}{'_decimal_format_group'} eq '.';
        return 1;
    }

    return [
        $self->{'language_data'}{'misc_info'}{'cldr_formats'}{'decimal'},
        $self->{'language_data'}{'misc_info'}{'cldr_formats'}{'_decimal_format_group'},
        $self->{'language_data'}{'misc_info'}{'cldr_formats'}{'_decimal_format_decimal'},
    ];
}

my $get_locale_display_pattern_from_code_fast = 0;

sub get_locale_display_pattern_from_code_fast {
    if ( !$get_locale_display_pattern_from_code_fast ) {
        $get_locale_display_pattern_from_code_fast++;
        require Locales::DB::LocaleDisplayPattern::Tiny;
    }

    if ( @_ == 1 && ref( $_[0] ) ) {
        return Locales::DB::LocaleDisplayPattern::Tiny::get_locale_display_pattern( $_[0]->get_locale() );
    }
    return Locales::DB::LocaleDisplayPattern::Tiny::get_locale_display_pattern( $_[-1] );    # last arg so it works as function or class method or object method
}

sub get_locale_display_pattern_from_code {
    my ( $self, $code, $always_return ) = @_;

    my $class = ref($self) ? ref($self) : $self;
    if ( !exists $self->{'locale_display_pattern_data'} ) {
        have_mod("$class\::DB::LocaleDisplayPattern") || return;

        no strict 'refs';                                                                    ## no critic
        $self->{'locale_display_pattern_data'} = {
            'VERSION'         => \${"$class\::DB::LocaleDisplayPattern::VERSION"},
            'cldr_version'    => \${"$class\::DB::LocaleDisplayPattern::cldr_version"},
            'code_to_pattern' => \%{"$class\::DB::LocaleDisplayPattern::code_to_pattern"},
        };
    }

    $code ||= $self->{'locale'};
    $code = normalize_tag($code);
    return if !defined $code;

    $always_return ||= 1 if $code eq $self->get_locale() && $self->get_soft_locale_fallback();    # force $always_return under soft locale objects
    $always_return ||= 0;

    if ( exists $self->{'locale_display_pattern_data'}{'code_to_pattern'}{$code} ) {
        return $self->{'locale_display_pattern_data'}{'code_to_pattern'}{$code};
    }
    elsif ($always_return) {
        my ( $l, $t ) = split_tag($code);
        if ( exists $self->{'locale_display_pattern_data'}{'code_to_pattern'}{$l} ) {
            return $self->{'locale_display_pattern_data'}{'code_to_pattern'}{$l};
        }
        return '{0} ({1})';
    }
    return;
}

my $get_character_orientation_from_code_fast = 0;

sub get_character_orientation_from_code_fast {
    if ( !$get_character_orientation_from_code_fast ) {
        $get_character_orientation_from_code_fast++;
        require Locales::DB::CharacterOrientation::Tiny;
    }

    if ( @_ == 1 && ref( $_[0] ) ) {
        return Locales::DB::CharacterOrientation::Tiny::get_orientation( $_[0]->get_locale() );
    }

    return Locales::DB::CharacterOrientation::Tiny::get_orientation( $_[-1] );    # last arg so it works as function or class method or object method
}

sub get_character_orientation_from_code {
    my ( $self, $code, $always_return ) = @_;

    my $class = ref($self) ? ref($self) : $self;
    if ( !exists $self->{'character_orientation_data'} ) {
        have_mod("$class\::DB::CharacterOrientation") || return;

        no strict 'refs';                                                         ## no critic
        $self->{'character_orientation_data'} = {
            'VERSION'      => \${"$class\::DB::CharacterOrientation::VERSION"},
            'cldr_version' => \${"$class\::DB::CharacterOrientation::cldr_version"},
            'code_to_name' => \%{"$class\::DB::CharacterOrientation::code_to_name"},
        };
    }

    $code ||= $self->{'locale'};
    $code = normalize_tag($code);
    return if !defined $code;

    $always_return ||= 1 if $code eq $self->get_locale() && $self->get_soft_locale_fallback();    # force $always_return under soft locale objects
    $always_return ||= 0;

    if ( exists $self->{'character_orientation_data'}{'code_to_name'}{$code} ) {
        return $self->{'character_orientation_data'}{'code_to_name'}{$code};
    }
    elsif ($always_return) {
        my ( $l, $t ) = split_tag($code);
        if ( exists $self->{'character_orientation_data'}{'code_to_name'}{$l} ) {
            return $self->{'character_orientation_data'}{'code_to_name'}{$l};
        }
        return 'left-to-right';
    }
    return;
}

sub get_plural_form_categories {
    return @{ $_[0]->{'language_data'}{'misc_info'}{'plural_forms'}{'category_list'} };
}

sub supports_special_zeroth {
    return 1 if $_[0]->get_plural_form(0) eq 'other';
    return;
}

sub plural_category_count {
    return scalar( $_[0]->get_plural_form_categories() );
}

sub get_plural_form {
    my ( $self, $n, @category_values ) = @_;
    my $category;
    my $has_extra_for_zero = 0;

    # This negative value behavior makes sense but is not defined either way in the CLDR.
    # We've asked for clarification via http://unicode.org/cldr/trac/ticket/4049
    # If CLDR introduces negatives then the rule parser needs to factor in those new rules
    #     and also perl's modulus-on-negative-values behavior
    my $abs_n = abs($n);    # negatives keep same category as positive

    if ( !$self->{'language_data'}{'misc_info'}{'plural_forms'}{'category_rules_function'} ) {
        $self->{'language_data'}{'misc_info'}{'plural_forms'}{'category_rules_function'} = Locales::plural_rule_hashref_to_code( $self->{'language_data'}{'misc_info'}{'plural_forms'} );
        if ( !defined $self->{'language_data'}{'misc_info'}{'plural_forms'}{'category_rules_function'} ) {
            require Carp;
            Carp::carp("Could not determine plural logic.");
        }
    }

    $category = $self->{'language_data'}{'misc_info'}{'plural_forms'}{'category_rules_function'}->($abs_n);

    my @categories = $self->get_plural_form_categories();

    if ( !@category_values ) {

        # no args will return the category name
        @category_values = @categories;
    }
    else {
        my $cat_len = @categories;
        my $val_len = @category_values;
        if ( $val_len == ( $cat_len + 1 ) ) {
            $has_extra_for_zero++;
        }
        elsif ( $cat_len != $val_len && $self->{'verbose'} ) {
            require Carp;
            Carp::carp("The number of given values ($val_len) does not match the number of categories ($cat_len).");
        }
    }

    if ( !defined $category ) {
        my $cat_idx = $has_extra_for_zero && $abs_n != 0 ? -2 : -1;
        return wantarray ? ( $category_values[$cat_idx], $has_extra_for_zero && $abs_n == 0 ? 1 : 0 ) : $category_values[$cat_idx];
    }
    else {
      GET_POSITION:
        my $cat_pos_in_list;
        my $index = -1;
      CATEGORY:
        for my $cat (@categories) {
            $index++;
            if ( $cat eq $category ) {
                $cat_pos_in_list = $index;
                last CATEGORY;
            }
        }

        if ( !defined $cat_pos_in_list && $category ne 'other' ) {
            require Carp;
            Carp::carp("The category ($category) is not used by this locale.");
            $category = 'other';
            goto GET_POSITION;
        }
        elsif ( !defined $cat_pos_in_list ) {
            my $cat_idx = $has_extra_for_zero && $abs_n != 0 ? -2 : -1;
            return wantarray ? ( $category_values[$cat_idx], $has_extra_for_zero && $abs_n == 0 ? 1 : 0 ) : $category_values[$cat_idx];
        }
        else {
            if ( $has_extra_for_zero && $category eq 'other' ) {    # and 'other' is at the end of the list? nah...  && $cat_pos_in_list + 1 == $#category_values
                my $cat_idx = $has_extra_for_zero && $abs_n == 0 ? -1 : $cat_pos_in_list;
                return wantarray ? ( $category_values[$cat_idx], $has_extra_for_zero && $abs_n == 0 ? 1 : 0 ) : $category_values[$cat_idx];
            }
            else {
                return wantarray ? ( $category_values[$cat_pos_in_list], 0 ) : $category_values[$cat_pos_in_list];
            }
        }
    }
}

# pending http://unicode.org/cldr/trac/ticket/4051
sub get_list_or {
    my ( $self, @items ) = @_;

    # I told you it was stub in the changelog, POD, test, and here!
    $self->_quote_get_list_items( \@items );

    return                          if !@items;
    return $items[0]                if @items == 1;
    return "$items[0] or $items[1]" if @items == 2;

    my $last = pop(@items);
    return join( ', ', @items ) . ", or $last";
}

sub _quote_get_list_items {
    my ( $self, $items_ar ) = @_;

    my $cnt = 0;

    if ( exists $self->{'misc'}{'list_quote_mode'} && $self->{'misc'}{'list_quote_mode'} ne 'none' ) {
        if ( $self->{'misc'}{'list_quote_mode'} eq 'all' ) {
            @{$items_ar} = ('') if @{$items_ar} == 0;

            for my $i ( 0 .. scalar( @{$items_ar} ) - 1 ) {
                $items_ar->[$i] = '' if !defined $items_ar->[$i];
                $items_ar->[$i] = $self->quote( $items_ar->[$i] );
                $cnt++;
            }
        }
        elsif ( $self->{'misc'}{'list_quote_mode'} eq 'some' ) {
            @{$items_ar} = ('') if @{$items_ar} == 0;

            for my $i ( 0 .. scalar( @{$items_ar} ) - 1 ) {
                $items_ar->[$i] = '' if !defined $items_ar->[$i];
                if ( $items_ar->[$i] eq '' || $items_ar->[$i] =~ m/\A(?: |\xc2\xa0)+\z/ ) {
                    $items_ar->[$i] = $self->quote( $items_ar->[$i] );
                    $cnt++;
                }
            }
        }
        else {
            require Carp;
            Carp::carp('$self->{misc}{list_quote_mode} is set to an unknown value');
        }
    }

    return $cnt;
}

sub get_list_and {
    my ( $self, @items ) = @_;

    $self->_quote_get_list_items( \@items );

    return if !@items;
    return $items[0] if @items == 1;

    if ( @items == 2 ) {
        my $two = $self->{'language_data'}{'misc_info'}{'cldr_formats'}{'list'}{'2'};
        $two =~ s/\{([01])\}/$items[$1]/g;
        return $two;
    }
    else {
        @items = map { my $c = $_; $c =~ s/\{([01])\}/__\{__${1}__\}__/g; $c } @items;    # I know ick, patches welcome

        my $aggregate = $self->{'language_data'}{'misc_info'}{'cldr_formats'}{'list'}{'start'};
        $aggregate =~ s/\{([01])\}/$items[$1]/g;

        for my $i ( 2 .. $#items ) {
            next if $i == $#items;
            my $middle = $self->{'language_data'}{'misc_info'}{'cldr_formats'}{'list'}{'middle'};
            $middle =~ s/\{0\}/$aggregate/g;
            $middle =~ s/\{1\}/$items[$i]/g;
            $aggregate = $middle;
        }

        my $end = $self->{'language_data'}{'misc_info'}{'cldr_formats'}{'list'}{'end'};
        $end =~ s/\{0\}/$aggregate/g;
        $end =~ s/\{1\}/$items[-1]/g;

        $end =~ s/__\{__([01])__\}__/\{$1\}/g;    # See "I know ick, patches welcome" above

        return $end;
    }
}

sub quote {
    my ( $self, $value ) = @_;
    $value = '' if !defined $value;

    return $self->{'language_data'}{'misc_info'}{'delimiters'}{'quotation_start'} . $value . $self->{'language_data'}{'misc_info'}{'delimiters'}{'quotation_end'};
}

sub quote_alt {
    my ( $self, $value ) = @_;
    $value = '' if !defined $value;

    return $self->{'language_data'}{'misc_info'}{'delimiters'}{'alternate_quotation_start'} . $value . $self->{'language_data'}{'misc_info'}{'delimiters'}{'alternate_quotation_end'};
}

sub get_formatted_ellipsis_initial {
    my ( $self, $str ) = @_;
    my $pattern = $self->{'language_data'}{'misc_info'}{'cldr_formats'}{'ellipsis'}{'initial'} || '…{0}';
    $pattern =~ s/\{0\}/$str/;
    return $pattern;
}

sub get_formatted_ellipsis_medial {
    my ($self) = @_;    # my ($self, $first, $second) = @_;
    my $pattern = $self->{'language_data'}{'misc_info'}{'cldr_formats'}{'ellipsis'}{'medial'} || '{0}…{1}';
    $pattern =~ s/\{(0|1)\}/$_[$1 + 1]/g;    # use index instead of variable to avoid formatter confusion, e.g. $first contains the string '{1}'
    return $pattern;
}

sub get_formatted_ellipsis_final {
    my ( $self, $str ) = @_;
    my $pattern = $self->{'language_data'}{'misc_info'}{'cldr_formats'}{'ellipsis'}{'final'} || '{0}…';
    $pattern =~ s/\{0\}/$str/;
    return $pattern;
}

# TODO get_formatted_percent() get_formatted_permille() other symbols like infinity, plus sign etc

sub get_formatted_decimal {
    my ( $self, $n, $max_decimal_places, $_my_pattern ) = @_;    # $_my_pattern not documented on purpose, it is only intended for internal use, and may dropepd/changed at any time

    # Format $n per $self->{'language_data'}{'misc_info'}{'cldr_formats'}{'decimal'}
    #   per http://cldr.unicode.org/translation/number-patterns

    # TODO: ? NaN from CLDR if undef or not d[.d] ?
    return if !defined $n;

    #### ##
    # 1) Turn $n into [0-9]+(?:\.[0-9]+)? even if scientifically large (or negative, since how negative numbers look is defined by the pattern)
    #### ##

    # Regaring $max_decimal_places: Number::Format will "Obtain precision from the length of the decimal part" of the pattern.
    # but CLDR says "The number of decimals will be set by the program" in our case the caller's input or sprintf()'s default.

    # this way we can remove any signs and still know if it was negative later on
    my $is_negative = $n < 0 ? 1 : 0;

    my $max_len = defined $max_decimal_places ? abs( int($max_decimal_places) ) : 6;    # %f default is 6
    $max_len = 14 if $max_len > 14;

    if ( $n > 10_000_000_000 || $n < -10_000_000_000 ) {

        # TODO: ? do exponential from CLDR ?
        return $n if $n =~ m/e/i;                                                       # poor man's is exponential check.

        # Emulate %f on large numbers strings
        # $n = "$n"; # turn it into a string, trailing zero's go away

        if ( $n =~ m/\.([0-9]{$max_len})([0-9])?/ ) {
            my $trim = $1;    # (defined $2 && $2 > 4) ? $1 + 1 : $1;

            if ( defined $2 && $2 > 4 ) {
                if ( ( $trim + 1 ) !~ m/e/i ) {    # poor man's is exponential check.
                    $trim++;
                }
            }

            # Yes, %f does it but why 0's only to lop them off immediately
            # while(CORE::length($trim) < $max_len) { $trim .= '0' }
            $n =~ s/\.[0-9]+/\.$trim/;
        }
    }
    else {
        $n = sprintf( '%.' . $max_len . 'f', $n );

        # TODO: ? do exponential from CLDR ?
        return $n if $n =~ m/e/i;    # poor man's is exponential check.
    }

    # [^0-9]+ will match the off chance of sprintf() using a
    # separator that is mutiple bytes or mutliple characters or both.
    # This holds true for both byte strings and Unicode strings.

    $n =~ s{([^0-9]+[0-9]*?[1-9])0+$}{$1};
    $n =~ s{[^0-9]+0+$}{};

    # [^0-9]+ will match the off chance of sprintf() using a
    # negative/positive symbol that is mutiple bytes or mutliple characters or both.
    # This holds true for both byte strings and Unicode strings.
    $n =~ s/^[^0-9]+//;    # strip signs since any would be defined in pattern

    #### ##
    # 2) Determine working format:
    #### ##

    my $format = $_my_pattern || $self->{'language_data'}{'misc_info'}{'cldr_formats'}{'decimal'};    # from http://unicode.org/repos/cldr-tmp/trunk/diff/by_type/number.pattern.html

    my ( $zero_positive_pat, $negative_pat, $err ) = split( /(?

    if ($err) {
        require Carp;
        Carp::carp("Format had more than 2 pos/neg sections. Using default pattern.");
        $format = '#,##0.###';
    }
    elsif ( $is_negative && $negative_pat ) {
        $format = $negative_pat;
    }
    elsif ($zero_positive_pat) {
        $format = $zero_positive_pat;
    }

    my $dec_sec_cnt = 0;
    $dec_sec_cnt++ while ( $format =~ m/(?
    if ( $dec_sec_cnt != 1 ) {
        require Carp;
        Carp::carp("Format should have one decimal section. Using default pattern.");
        $format = '#,##0.###';
    }

    if ( !defined $format || $format eq '' || $format =~ m/^\s+$/ ) {
        require Carp;
        Carp::carp("Format is empty. Using default pattern.");
        $format = '#,##0.###';
    }

    #### ##
    # 3) format $n per $format
    #### ##

    my $result = '';

    if ( $format eq '#,##0.###' ) {
        $result = $n;
        while ( $result =~ s/^([-+]?\d+)(\d{3})/$1,$2/s ) { 1 }    # right from perlfaq5
    }
    else {

        # period that is not literal (?
        # comma that is not literal (?

        # !!!! This is sort of where the CLDR documentation gets anemic, patches welcome !!

        # TODO: ? better efficiency (e.g. less/no array voo doo) w/ same results, patches ... well you know ?

        my ( $integer, $decimals ) = split( /\./, $n, 2 );

        my ( $i_pat, $d_pat ) = split( /(?
        my ( $cur_idx, $trailing_non_n, $cur_d, $cur_pat ) = ( 0, '' );    # buffer

        # integer: right to left
        my @i_pat = reverse( split( /(?

        my $next_to_last_pattern = @i_pat == 1 ? $i_pat[0] : $i_pat[-2];
        $next_to_last_pattern =~ s/0$/#/;
        while ( $i_pat[0] =~ s/((?:\'.\')+)$// || $i_pat[0] =~ s/([^0#]+)$// ) {
            $trailing_non_n = "$1$trailing_non_n";
        }

        # my $loop_cnt = 0;
        # my $loop_max = CORE::length($i_pat . $integer) + 100;

        while ( CORE::length( $cur_d = CORE::substr( $integer, -1, 1, '' ) ) ) {

            # if ($loop_cnt > $loop_max) {
            #     require Carp;
            #     Carp::carp('Integer pattern parsing results in infinite loop.');
            #     last;
            # }
            # $loop_cnt++;

            if ( $cur_idx == $#i_pat && !CORE::length( $i_pat[$cur_idx] ) ) {
                $i_pat[$cur_idx] = $next_to_last_pattern;
            }

            if ( !CORE::length( $i_pat[$cur_idx] ) ) {    # this chunk is spent
                if ( defined $i_pat[ $cur_idx + 1 ] ) {    # there are more chunks ...
                    $cur_idx++;                            # ... next chunk please
                }
            }

            if ( CORE::length( $i_pat[$cur_idx] ) ) {

                # if the next thing is a literal:
                if ( $i_pat[$cur_idx] =~ m/(\',\')$/ ) {
                    $result = CORE::substr( $i_pat[$cur_idx], -3, 3, '' ) . $result;
                    redo;
                }

                $cur_pat = CORE::substr( $i_pat[$cur_idx], -1, 1, '' );

                if ( $cur_pat ne '0' && $cur_pat ne '#' ) {
                    $result = "$cur_pat$result";
                    redo;
                }
            }

            $result = !CORE::length( $i_pat[$cur_idx] ) && @i_pat != 1 ? ",$cur_d$result" : "$cur_d$result";

            if ( $cur_idx == $#i_pat - 1 && $i_pat[$#i_pat] eq '#' && !CORE::length( $i_pat[$cur_idx] ) ) {
                $cur_idx++;
                $i_pat[$cur_idx] = $next_to_last_pattern;
            }
        }
        if ( CORE::length( $i_pat[$cur_idx] ) ) {
            $i_pat[$cur_idx] =~ s/(?
            $result = $result . $i_pat[$cur_idx];        # prepend it (e.g. 0 and -)
        }
        if ( substr( $result, 0, 1 ) eq ',' ) {
            substr( $result, 0, 1, '' );
        }
        $result .= $trailing_non_n;

        if ( defined $decimals && CORE::length($decimals) ) {

            # decimal: left to right
            my @d_pat = ($d_pat);                        # TODO ? support sepeartor in decimal, !definedvia CLDR, no patterns have that ATM ? split( /(?

            $result .= '.';
            $cur_idx        = 0;
            $trailing_non_n = '';

            while ( $d_pat[-1] =~ s/((?:\'.\')+)$// || $d_pat[-1] =~ s/([^0#]+)$// ) {
                $trailing_non_n = "$1$trailing_non_n";
            }

            # $loop_cnt = 0;
            # $loop_max = CORE::length($d_pat . $decimals) + 100;

            while ( CORE::length( $cur_d = CORE::substr( $decimals, 0, 1, '' ) ) ) {

                # if ($loop_cnt > $loop_max) {
                #     require Carp;
                #     Carp::carp('Decimal pattern parsing results in infinite loop.');
                #     last;
                # }
                # $loop_cnt++;

                if ( !CORE::length( $d_pat[$cur_idx] ) ) {    # this chunk is spent
                    if ( !defined $d_pat[ $cur_idx + 1 ] ) {    # there are no more chunks
                        $cur_pat = '#';
                    }
                    else {                                      # next chunk please
                        $result .= ',';
                        $cur_idx++;
                    }
                }

                if ( CORE::length( $d_pat[$cur_idx] ) ) {

                    # if the next thing is a literal:
                    if ( $d_pat[$cur_idx] =~ m/^(\'.\')/ ) {
                        $result .= CORE::substr( $d_pat[$cur_idx], 0, 3, '' );
                        redo;
                    }
                    $cur_pat = CORE::substr( $d_pat[$cur_idx], 0, 1, '' );
                    if ( $cur_pat ne '0' && $cur_pat ne '#' ) {
                        $result .= $cur_pat;
                        redo;
                    }
                }

                $result .= $cur_d;
            }
            if ( substr( $result, -1, 1 ) eq ',' ) {
                substr( $result, -1, 1, '' );
            }
            if ( defined $d_pat[$cur_idx] ) {
                $d_pat[$cur_idx] =~ s/(?
                $result .= $d_pat[$cur_idx];                 # append it (e.g. 0 and -)
            }
            $result .= $trailing_non_n;
        }

        # END: "This is sort of where the CLDR documentation gets anemic"
    }

    $result =~ s/(?
    $result =~ s/(?{language_data}{misc_info}{cldr_formats}{_decimal_format_group}/g;
    $result =~ s/_LOCALES-DECIMAL-PLACEHOLDER_/$self->{language_data}{misc_info}{cldr_formats}{_decimal_format_decimal}/g;

    # TODO ? turn 0-9 into non0-9 digits if defined as such in CLDR ?

    if ( $is_negative && !$negative_pat ) {

        # This is default since CLDR says to specify a special negative pattern if
        #    "your language uses different formats for negative numbers than just adding "-" at the front"
        $result = "-$result";
    }

    return $result;
}

#### territory ####

sub get_territory_codes {
    return keys %{ shift->{'territory_data'}{'code_to_name'} };
}

sub get_territory_names {
    return values %{ shift->{'territory_data'}{'code_to_name'} };
}

sub get_territory_lookup {
    return %{ shift->{'territory_data'}{'code_to_name'} };
}

sub get_territory_from_code {
    my ( $self, $code, $always_return ) = @_;

    $code ||= $self->{'territory'};
    $code = normalize_tag($code);
    return if !defined $code;

    # this is not needed in this method:
    # $always_return ||= 1 if $code eq $self->get_locale() && $self->get_soft_locale_fallback(); # force $always_return under soft locale objects

    if ( exists $self->{'territory_data'}{'code_to_name'}{$code} ) {
        return $self->{'territory_data'}{'code_to_name'}{$code};
    }
    elsif ( !defined $self->{'territory'} || $code ne $self->{'territory'} ) {
        my ( $l, $t ) = split_tag($code);
        if ( $t && exists $self->{'territory_data'}{'code_to_name'}{$t} ) {
            return $self->{'territory_data'}{'code_to_name'}{$t};
        }
    }
    return $code if $always_return;
    return;
}

sub get_code_from_territory {
    my ( $self, $name ) = @_;
    return if !$name;
    my $key = normalize_for_key_lookup($name);
    if ( exists $self->{'territory_data'}{'name_to_code'}{$key} ) {
        return $self->{'territory_data'}{'name_to_code'}{$key};
    }
    return;
}

{
    no warnings 'once';
    *code2territory = \&get_territory_from_code;
    *territory2code = \&get_code_from_territory;
}

#### language ####

sub get_language_codes {
    return keys %{ shift->{'language_data'}{'code_to_name'} };
}

sub get_language_names {
    return values %{ shift->{'language_data'}{'code_to_name'} };
}

sub get_language_lookup {
    return %{ shift->{'language_data'}{'code_to_name'} };
}

sub get_language_from_code {
    my ( $self, $code, $always_return ) = @_;

    $code ||= $self->{'locale'};
    $code = normalize_tag($code);
    return if !defined $code;

    $always_return ||= 1 if $code eq $self->get_locale() && $self->get_soft_locale_fallback();    # force $always_return under soft locale objects
    $always_return ||= 0;

    if ( exists $self->{'language_data'}{'code_to_name'}{$code} ) {
        return $self->{'language_data'}{'code_to_name'}{$code};
    }
    elsif ($always_return) {
        my ( $l, $t ) = split_tag($code);
        my $ln = $self->{'language_data'}{'code_to_name'}{$l};
        my $tn = defined $t ? $self->{'territory_data'}{'code_to_name'}{$t} : '';

        return $code if !$ln && !$tn;
        $ln ||= $l;
        $tn ||= $t;

        my $string = $self->{'language_data'}{'misc_info'}{'cldr_formats'}{'locale'} || '{0} ({1})';
        $string =~ s/\{0\}/$ln/g;
        $string =~ s/\{1\}/$tn/g;

        return $string;
    }
    return;
}

sub get_code_from_language {
    my ( $self, $name ) = @_;
    return if !$name;
    my $key = normalize_for_key_lookup($name);
    if ( exists $self->{'language_data'}{'name_to_code'}{$key} ) {
        return $self->{'language_data'}{'name_to_code'}{$key};
    }
    return;
}

{
    no warnings 'once';
    *code2language = \&get_language_from_code;
    *language2code = \&get_code_from_language;
}

#### utility functions ####

sub tag_is_soft_locale {
    my ($tag) = @_;
    my ( $l, $t ) = split_tag($tag);

    return if !defined $l;    # invalid tag is not soft

    return if !$t;                             # no territory part means it is not soft
    return if tag_is_loadable($tag);           # if it can be loaded directly then it is not soft
    return if !territory_code_is_known($t);    # if the territory part is not known then it is not soft
    return if !tag_is_loadable($l);            # if the language part is not known then it is not soft
    return $l;                                 # it is soft, so return the value suitable for 'soft_locale_fallback'
}

sub tag_is_loadable {
    my ( $tag, $as_territory ) = @_;           # not documenting internal $as_territory, just use territory_code_is_known() directly
    have_mod("Locales::DB::Loadable") || return;

    if ($as_territory) {
        return 1 if exists $Locales::DB::Loadable::territory{$tag};
    }
    else {
        return 1 if exists $Locales::DB::Loadable::code{$tag};
    }

    return;
}

sub get_loadable_language_codes {
    have_mod("Locales::DB::Loadable") || return;
    return keys %Locales::DB::Loadable::code;
}

sub territory_code_is_known {
    return tag_is_loadable( $_[0], 1 );
}

sub split_tag {
    return split( /_/, normalize_tag( $_[0] ), 2 );    # we only do language[_territory]
}

sub get_i_tag_for_string {
    my $norm = normalize_tag( $_[0] );

    if ( substr( $norm, 0, 2 ) eq 'i_' ) {
        return $norm;
    }
    else {
        return 'i_' . $norm;
    }
}

my %non_locales = (
    'und' => 1,
    'zxx' => 1,
    'mul' => 1,
    'mis' => 1,
    'art' => 1,
);

sub non_locale_list {
    return ( sort keys %non_locales );
}

sub is_non_locale {
    my $tag = normalize_tag( $_[0] ) || return;
    return 1 if exists $non_locales{$tag};
    return;
}

sub typical_en_alias_list {
    return ( 'en_us', 'i_default' );
}

sub is_typical_en_alias {
    my $tag = normalize_tag( $_[0] ) || return;
    return 1 if $tag eq 'en_us' || $tag eq 'i_default';
    return;
}

sub normalize_tag {
    my $tag = $_[0];
    return if !defined $tag;
    $tag =~ tr/A-Z/a-z/;
    $tag =~ s{\s+}{}g;
    $tag =~ s{[^a-z0-9]+$}{};    # I18N::LangTags::locale2language_tag() does not allow trailing '_'
    $tag =~ s{[^a-z0-9]+}{_}g;

    # would like to do this with a single call, backtracking or indexing ? patches welcome!
    while ( $tag =~ s/([^_]{8})([^_])/$1\_$2/ ) { }    # I18N::LangTags::locale2language_tag() only allows parts bewteen 1 and 8 character
    return $tag;
}

sub normalize_tag_for_datetime_locale {
    my ( $pre, $pst ) = split_tag( $_[0] );            # we only do language[_territory]
    return if !defined $pre;

    if ($pst) {
        return $pre . '_' . uc($pst);
    }
    else {
        return $pre;
    }
}

sub normalize_tag_for_ietf {
    my ( $pre, $pst ) = split_tag( $_[0] );            # we only do language[_territory]
    return if !defined $pre;

    if ($pst) {
        return $pre . '-' . uc($pst);
    }
    else {
        return $pre;
    }
}

sub normalize_for_key_lookup {
    my $key = $_[0];
    return if !defined $key;
    $key =~ tr/A-Z/a-z/;    # lowercase
                            # $key =~ s{^\s+}{};   # trim WS from begining
                            # $key =~ s{\s+$}{};   # trim WS from end
                            # $key =~ s{\s+}{ }g;   # collapse multi WS to one space
    $key =~ s{\s+}{}g;
    $key =~ s{[\'\"\-\(\)\[\]\_]+}{}g;
    return $key;
}

sub plural_rule_string_to_javascript_code {
    my ( $plural_rule_string, $return ) = @_;
    my $perl = plural_rule_string_to_code( $plural_rule_string, $return );
    $perl =~ s/sub \{ /function (n) {/;
    $perl =~ s/\$_\[0\]/n/g;
    $perl =~ s/ \(n \% ([0-9]+)\) \+ \(n-int\(n\)\) /n % $1/g;
    $perl =~ s/int\(/parseInt\(/g;
    return $perl;
}

sub plural_rule_string_to_code {
    my ( $plural_rule_string, $return ) = @_;
    if ( !defined $return ) {
        $return = 1;
    }

    # if you have a better way, patches welcome!!

    my %m;
    while ( $plural_rule_string =~ m/mod ([0-9]+)/g ) {

        # CLDR plural rules (http://unicode.org/reports/tr35/#Language_Plural_Rules):
        #      'mod' (modulus) is a remainder operation as defined in Java; for example, the result of "4.3 mod 3" is 1.3.
        $m{$1} = "( (\$_[0] % $1) + (\$_[0]-int(\$_[0])) )";
    }

    my $perl_code = "sub { if (";

    for my $or ( split /\s+or\s+/i, $plural_rule_string ) {
        my $and_exp;
        for my $and ( split /\s+and\s+/i, $or ) {
            my $copy = $and;
            my $n    = '$_[0]';

            $copy =~ s/ ?n is not / $n \!\= /g;
            $copy =~ s/ ?n is / $n \=\= /g;

            $copy =~ s/ ?n mod ([0-9]+) is not / $m{$1} \!\= /g;
            $copy =~ s/ ?n mod ([0-9]+) is / $m{$1} \=\= /g;

            # 'in' is like 'within' but it has to be an integer
            $copy =~ s/ ?n not in ([0-9]+)\s*\.\.\s*([0-9]+) ?/ int\($n\) \!\= $n \|\| $n < $1 \|\| $n \> $2 /g;
            $copy =~ s/ ?n mod ([0-9]+) not in ([0-9]+)\s*\.\.\s*([0-9]+) ?/ int\($n\) \!\= $n \|\| $m{$1} < $2 \|\| $m{$1} \> $3 /g;

            # 'within' is like 'in' except is inclusive of decimals
            $copy =~ s/ ?n not within ([0-9]+)\s*\.\.\s*([0-9]+) ?/ \($n < $1 \|\| $n > $2\) /g;
            $copy =~ s/ ?n mod ([0-9]+) not within ([0-9]+)\s*\.\.\s*([0-9]+) ?/ \($m{$1} < $2 \|\| $m{$1} > $3\) /g;

            # 'in' is like 'within' but it has to be an integer
            $copy =~ s/ ?n in ([0-9]+)\s*\.\.\s*([0-9]+) ?/ int\($n\) \=\= $n \&\& $n \>\= $1 \&\& $n \<\= $2 /g;
            $copy =~ s/ ?n mod ([0-9]+) in ([0-9]+)\s*\.\.\s*([0-9]+) ?/ int\($n\) \=\= $n \&\& $m{$1} \>\= $2 \&\& $m{$1} \<\= $3 /g;

            # 'within' is like 'in' except is inclusive of decimals
            $copy =~ s/ ?n within ([0-9]+)\s*\.\.\s*([0-9]+) ?/ $n \>\= $1 \&\& $n \<\= $2 /g;
            $copy =~ s/ ?n mod ([0-9]+) within ([0-9]+)\s*\.\.\s*([0-9]+) ?/ $m{$1} \>\= $2 \&\& $m{$1} \<\= $3 /g;

            if ( $copy eq $and ) {
                require Carp;
                Carp::carp("Unknown plural rule syntax");
                return;
            }
            else {
                $and_exp .= "($copy) && ";
            }
        }
        $and_exp =~ s/\s+\&\&\s*$//;

        if ($and_exp) {
            $perl_code .= " ($and_exp) || ";
        }
    }
    $perl_code =~ s/\s+\|\|\s*$//;

    $perl_code .= ") { return '$return'; } return;}";

    return $perl_code;
}

sub plural_rule_hashref_to_code {
    my ($hr) = @_;

    if ( ref( $hr->{'category_rules'} ) ne 'HASH' ) {

        # this should never happen but if it does lets default to en's version
        $hr->{'category_rules_compiled'} = {
            'one' => q{sub { return 'one' if ( ( $n == 1 ) ); return;};},
        };

        return sub {

            my ($n) = @_;
            return 'one' if $n == 1;
            return;
        };
    }
    else {
        for my $cat ( get_cldr_plural_category_list(1) ) {
            next if !exists $hr->{'category_rules'}{$cat};
            next if exists $hr->{'category_rules_compiled'}{$cat};
            $hr->{'category_rules_compiled'}{$cat} = plural_rule_string_to_code( $hr->{'category_rules'}{$cat}, $cat );
        }

        return sub {
            my ($n) = @_;
            my $match;
          PCAT:
            for my $cat ( get_cldr_plural_category_list(1) ) {    # use function instead of keys to preserve processing order
                next if !exists $hr->{'category_rules_compiled'}{$cat};

                # Does $n match $hr->{$cat} ?

                if ( ref( $hr->{'category_rules_compiled'}{$cat} ) ne 'CODE' ) {

                    local $SIG{__DIE__};                          # prevent benign eval from tripping potentially fatal sig handler, moot w/ Module::Want 0.6
                    $hr->{'category_rules_compiled'}{$cat} = eval "$hr->{'category_rules_compiled'}{$cat}";    ## no critic # As of 0.22 this will be skipped for modules included w/ the main dist
                }

                if ( $hr->{'category_rules_compiled'}{$cat}->($n) ) {
                    $match = $cat;
                    last PCAT;
                }
            }

            return $match if $match;
            return;
        };
    }
}

sub get_cldr_plural_category_list {

    return qw(zero one two few many other) if $_[0];    # check order

    # Order is important for Locale::Maketext::Utils::quant():
    #   one (singular), two (dual), few (paucal), many, other, zero
    return qw(one two few many other zero);    # quant() arg order
}

sub get_fallback_list {
    my ( $self, $special_lookup ) = @_;

    my ( $super, $ter ) = split_tag( $self->{'locale'} );
    return (
        $self->{'locale'},
        ( $super ne $self->{'locale'} && $super ne 'i' ? $super : () ),
        ( @{ $self->{'language_data'}{'misc_info'}{'fallback'} } ),
        (
            defined $special_lookup && ref($special_lookup) eq 'CODE'
            ? ( map { my $n = Locales::normalize_tag($_); $n ? ($n) : () } $special_lookup->( $self->{'locale'} ) )
            : ()
        ),
        'en'
    );
}

# get_cldr_$chart_$type_$name or better naming ?
sub get_cldr_number_symbol_decimal {
    return $_[0]->{'language_data'}{'misc_info'}{'cldr_formats'}{'_decimal_format_decimal'} || '.';
}

sub get_cldr_number_symbol_group {
    return $_[0]->{'language_data'}{'misc_info'}{'cldr_formats'}{'_decimal_format_group'} || ',';
}

1;

__END__