• Your recent searches
AmberDB
17 results

 view release on metacpan or  search on metacpan

lib/AmberDB/Locale.pm  view on Meta::CPAN 

#
# USAGE:
#   # New API (explicit language):
#   my $lang = AmberDB::Locale->new(language => "gb");
#   my $lang = AmberDB::Locale->new(language => "tr");
#
#   # With AmberDB engine (language from cfg, defaults to "gb"):
#   AmberDB->new(cfg => { language => "gb" });
#   # then $self->uc($str) works on the inherited object
# -------------------------------------------------------


# -------------------------------------------------------
# Constructor
# -------------------------------------------------------
sub new {
    my $class = shift;

    my $lang;

    # Handle calling conventions:
    #   1. new(language => "gb")     — named-param API
    #   2. new({ language => "gb" }) — unblessed hash ref API
    #   3. new("gb")                 — positional string API
    #   4. new()                     — no args; use default ("gb")
    if ( @_ ) {
        if ( @_ == 1 && !ref( $_[0] ) ) {
            $lang = $_[0];
        }
        elsif ( @_ == 1 && ref( $_[0] ) eq 'HASH' ) {
            $lang = $_[0]->{language} || $_[0]->{lang};
        }
        elsif ( @_ % 2 == 0 && !ref( $_[0] ) ) {
            my %args = @_;
            $lang = $args{language} || $args{lang};
        }
    }

    my %LANG_ALIAS = (
        'turkish'     => 'tr',
        'tr_tr'       => 'tr',
        'tr-tr'       => 'tr',
        'english'     => 'en',
        'en_us'       => 'en',
        'en_gb'       => 'gb',
        'german'      => 'de',
        'de_de'       => 'de',
        'french'      => 'fr',
        'fr_fr'       => 'fr',
        'spanish'     => 'es',
        'es_es'       => 'es',
        'russian'     => 'ru',
        'ru_ru'       => 'ru',
        'arabic'      => 'ar',
        'ar_sa'       => 'ar',
        'azerbaijani' => 'az',
        'az_az'       => 'az',
        'japanese'    => 'ja',
        'ja_jp'       => 'ja',
        'ja-jp'       => 'ja',
        'global'      => 'gb',
        'gb'          => 'gb',
        'gl'          => 'gb',
        'universal'   => 'gb',
        'uni'         => 'gb',
        'gb_base'     => 'gb',
    );

    $lang = lc( $lang // '' );
    $lang =~ s/[^\w-]//g;
    my $norm_lang = $LANG_ALIAS{$lang} || ( split /[_-]/, $lang )[0] || 'gb';

    # Fast path: instance cache lookup (keyed by class + normalized language)
    my $cache_key = "${class}::${norm_lang}";
    return $LOCALE_CACHE{$cache_key} if $LOCALE_CACHE{$cache_key};

    my $self = bless { _lang => $norm_lang }, $class;
    $self->_load_locale($norm_lang);

    if ( $self->{_lang} ) {
        $LOCALE_CACHE{$cache_key} = $self;
        $LOCALE_CACHE{"${class}::$self->{_lang}"} = $self;
    }

    return $self;
}

# -------------------------------------------------------
# Load locale data from AmberDB::Locale::Lang::<lang>
# Falls back to 'gb' if requested locale not found.
# -------------------------------------------------------
sub _load_locale {
    my ( $self, $lang ) = @_;

    $lang ||= 'gb';
    $self->{_lang} = $lang;

    my $locale_class = "AmberDB::Locale::Lang::$lang";
    my $loaded = eval {
        ( my $path = $locale_class ) =~ s|::|/|g;
        require "$path.pm";
        1;
    };

    unless ($loaded) {
        if ( $lang ne 'gb' ) {
            unless ( $WARNED_LOCALES{$lang}++ ) {
                cluck "AmberDB::Locale: locale '$lang' not found, falling back to 'gb'\n";
            }
            $locale_class = 'AmberDB::Locale::Lang::gb';
            require AmberDB::Locale::Lang::gb;
            $self->{_lang} = 'gb';
        }
    }

    $self->{_locale} = $locale_class->data();

    # Initialize Unicode::Collate::Locale for UCA standard collation
    eval {
        require Unicode::Collate::Locale;
        $self->{_collator} = Unicode::Collate::Locale->new( locale => $lang );

lib/AmberDB/Locale.pm  view on Meta::CPAN 


    my ( $day, $month, $year, $hour, $min, $sec ) = ( 0, 0, 0, 0, 0, 0 );

    if ( $str =~ /^(\d{1,2})[.\/-](\d{1,2})[.\/-](\d{4})(?:\s+(\d{1,2}):(\d{1,2}):?(\d{1,2})?)?/ ) {
        my ( $p1, $p2, $p3 ) = ( int($1), int($2), int($3) );
        $hour = int( $4 // 0 );
        $min  = int( $5 // 0 );
        $sec  = int( $6 // 0 );

        my $fmt = $self->{_locale}{date_format}{short} || 'DD.MM.YYYY';
        if ( $fmt =~ /^MM/i ) {
            $month = $p1;
            $day   = $p2;
            $year  = $p3;
        }
        else {
            $day   = $p1;
            $month = $p2;
            $year  = $p3;
        }
    }
    elsif ( $str =~ /^(\d{4})[.\/-](\d{1,2})[.\/-](\d{1,2})(?:\s+(\d{1,2}):(\d{1,2}):?(\d{1,2})?)?/ ) {
        $year  = int($1);
        $month = int($2);
        $day   = int($3);
        $hour  = int( $4 // 0 );
        $min   = int( $5 // 0 );
        $sec   = int( $6 // 0 );
    }

    return unless $year && $month && $day;

    if ( $opts{hash} ) {
        return {
            year   => $year,
            month  => $month,
            day    => $day,
            hour   => $hour,
            minute => $min,
            second => $sec,
        };
    }

    require Time::Local;
    return eval { Time::Local::timelocal( $sec, $min, $hour, $day, $month - 1, $year ) };
}

# Private helper: securely evaluate sanitized CLDR plural expressions
sub _eval_plural_rule {
    my ( $self, $cond, $count ) = @_;
    return 0 unless defined $cond && length $cond;

    my $n = abs( $count // 0 );

    # Whitelist strictly only digits, 'n', whitespace, arithmetic and logical operators
    return 0 unless $cond =~ /^[n0-9+\-*\/%&|!=<>()\s]+$/;

    # Replace 'n' variable token with actual numeric value
    ( my $expr = $cond ) =~ s/\bn\b/$n/g;

    # Safely evaluate numeric expression isolated from global DIE handlers
    my $res = eval {
        local $SIG{__DIE__} = sub {};
        eval $expr; ## no critic
    };
    return $res ? 1 : 0;
}

# -------------------------------------------------------
# Evaluate CLDR plural rule and select template.
#
# my $text = $lang->plural(1, { one => "{count} ürün", other => "{count} ürün" });
# my $text = $lang->plural(5, { one => "{count} item", other => "{count} items" });
# -------------------------------------------------------
sub plural {
    my ( $self, $count, $forms ) = @_;
    return '' unless defined $forms;

    $count //= 0;
    my $form_key = 'other';

    my $rule = $self->{_locale}{plural_rule} || 'one{n==1}other';

    for my $key (qw(zero one two few many)) {
        if ( $rule =~ /\b$key\{([^{}]+)\}/ ) {
            my $cond = $1;
            if ( $self->_eval_plural_rule( $cond, $count ) ) {
                $form_key = $key;
                last;
            }
        }
    }

    my $template;
    if ( ref($forms) eq 'HASH' ) {
        $template = $forms->{$form_key} // $forms->{other} // $forms->{one} // '';
    }
    else {
        $template = "$forms";
    }

    my $fmt_count = $self->format_number($count, decimals => 0);
    $template =~ s/\{count\}|\{n\}/$fmt_count/g;

    return $template;
}

# -------------------------------------------------------
# Language tag accessor
# my $tag = $lang->language;   # "tr", "en", "de" ...
# -------------------------------------------------------
sub language { return $_[0]->{_lang} }

1;

__END__

=encoding utf8

=head1 NAME

lib/AmberDB/Locale.pm  view on Meta::CPAN 

  # Russian: 4 forms (one, few, many, other)
  my %ru_apple = (
      one   => "{count} яблоко",
      few   => "{count} яблока",
      many  => "{count} яблок",
      other => "{count} яблока"
  );
  $ru->plural(1,  \%ru_apple);      # "1 яблоко"  (ends in 1, except 11)
  $ru->plural(3,  \%ru_apple);      # "3 яблока"  (ends in 2-4, except 12-14)
  $ru->plural(5,  \%ru_apple);      # "5 яблок"   (ends in 5-9, 0, or 11-14)
  $ru->plural(21, \%ru_apple);      # "21 яблоко"

=head1 DESCRIPTION

C<AmberDB::Locale> is a comprehensive, high-performance, locale-aware text processing engine designed for multilingual Perl applications. It provides a unified API for:

=over 4

=item * Locale-aware case conversion (e.g., Turkish C<I/ı>, C<İ/i>, German C<ß -E<gt> SS>).

=item * 100% standard Unicode Collation Algorithm (UCA) sorting via C<Unicode::Collate::Locale>.

=item * ASCII transliteration and URL slug generation with language-specific rules (e.g. German DIN 5007-2 C<ü -E<gt> ue> vs. Turkish C<ü -E<gt> u>).

=item * Written number and cheque printing conversion supporting integer, decimal, negative numbers, and Eastern Arabic/Persian numerals.

=item * Precision number and ISO 4217 currency formatting with customizable decimal and group separators.

=item * Bidirectional date/time formatting with full pattern tokens (C<YYYY>, C<MMMM>, C<dddd>, C<HH:mm:ss>) and parsing.

=item * Unicode NFKC case-folding and phonetic search token normalization for high-performance inverted indexes.

=item * CLDR-standard plural form evaluation across Western, Slavic, and Eastern languages.

=item * UTF-8 character-safe substring extraction preventing multi-byte corruption.

=back

Language-specific datasets and rule tables are decoupled into modular packages (e.g. C<AmberDB::Locale::Lang::gb>, C<AmberDB::Locale::Lang::tr>, C<AmberDB::Locale::Lang::de>, C<AmberDB::Locale::Lang::en>, C<AmberDB::Locale::Lang::ru>, C<AmberDB::Loca...

B<Inheritance Note:> C<AmberDB> inherits from C<AmberDB::Locale> via C<use parent>. When an C<AmberDB> instance is constructed, it automatically initializes its locale subsystem from C<$adb-E<gt>config('language')>. All methods documented below can b...

=head1 CONSTRUCTOR

=head2 new([%options | $hashref | $language_code])

Creates and returns an C<AmberDB::Locale> instance configured for the specified language. Instances are cached internally for high-throughput reuse.

  # 1. Named-parameter API (recommended)
  my $lang = AmberDB::Locale->new(language => 'tr');

  # 2. Hashref API
  my $lang = AmberDB::Locale->new({ language => 'de' });

  # 3. Positional string API
  my $lang = AmberDB::Locale->new('fr');

  # 4. Default (falls back to Global Base 'gb')
  my $lang = AmberDB::Locale->new();

Supported language codes include C<"gb"> (Global Base - default), C<"tr">, C<"en">, C<"de">, C<"fr">, C<"es">, C<"ru">, C<"az">, C<"ar">, C<"ja"> and common aliases (such as C<"global">, C<"turkish">, C<"tr_tr">, C<"english">, C<"german">, etc.).
If an unsupported language is specified, a warning is issued and the instance falls back to C<"gb">.

=head1 METHODS

=head2 Case Conversions & Comparison

=head3 uc($string)

Converts C<$string> to uppercase according to locale-specific casing rules.

  # Turkish dotted/dotless I handling:
  $tr->uc("ığdır");     # "IĞDIR"
  $tr->uc("istanbul");  # "Ä°STANBUL" (Turkish i -> Ä°)

  # English standard casing:
  $en->uc("istanbul");  # "ISTANBUL" (English i -> I)

  # German sharp S:
  $de->uc("straße");    # "STRASSE"  (German ß -> SS)

=head3 lc($string)

Converts C<$string> to lowercase according to locale-specific casing rules.

  # Turkish dotted/dotless I handling:
  $tr->lc("Ä°STANBUL");  # "istanbul" (Turkish Ä° -> i)
  $tr->lc("IĞDIR");     # "ığdır"    (Turkish I -> ı)

  # English standard casing:
  $en->lc("IĞDIR");     # "iğdır"    (English I -> i)

=head3 ucfirst($string)

Capitalizes the first letter of each word in C<$string> under locale rules. The string is first lowercased, and then the first character following word-starting delimiters (spaces, punctuation, brackets) is uppercased according to locale rules.

  $tr->ucfirst("istanbul büyükşehir belediyesi");
  # => "İstanbul Büyükşehir Belediyesi"

  $tr->ucfirst("ahmet (ısparta) - izmir");
  # => "Ahmet (Isparta) - Ä°zmir"

=head3 fold($string)

Applies Unicode NFKC normalization and locale lowercasing to produce a case-folded string suitable for search indexing and matching.

  my $key = $tr->fold("Ä°STANBUL"); # "istanbul"

=head3 ieq($str1, $str2)

Performs a locale-aware, case-insensitive comparison between C<$str1> and C<$str2>. Returns C<1> if they are equal under locale rules, C<0> otherwise.

  $tr->ieq("Ä°stanbul", "istanbul"); # 1 (true)
  $tr->ieq("IĞDIR", "ığdır");       # 1 (true)
  $tr->ieq("Ankara", "Ä°zmir");      # 0 (false)

=head2 Sorting

=head3 sort(\@list [, $field_or_index])

Sorts an array reference C<\@list> using the Unicode Collation Algorithm (UCA) tailored for the active locale.



( run in 1.798 second using v1.01-cache-2.11-cpan-4716db65a44 )