AmberDB
view release on metacpan or search on metacpan
lib/AmberDB/Locale.pm view on Meta::CPAN
package AmberDB::Locale;
use 5.016;
use warnings;
use utf8;
use Encode qw(decode encode);
use Carp qw(croak cluck);
our $VERSION = '5.25.1';
my $CREATED = '2017-07-22';
my %LOCALE_CACHE;
my %WARNED_LOCALES;
# -------------------------------------------------------
# AmberDB::Locale — Locale-aware string operations
#
# Formerly a Turkish-only module; now a generic locale
# engine that loads per-language data from AmberDB::Locale::Lang::*
#
# 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',
lib/AmberDB/Locale.pm view on Meta::CPAN
}
# Pre-compile phonetic assimilation / final-devoicing rules
if ( my $pm = $loc->{phonetic_map} ) {
my @rules;
if ( ref($pm) eq 'HASH' ) {
foreach my $pat ( keys %$pm ) {
push @rules, [ qr/$pat/i, $pm->{$pat} ];
}
}
elsif ( ref($pm) eq 'ARRAY' ) {
foreach my $pair (@$pm) {
my ( $pat, $sub ) = @$pair;
push @rules, [ qr/$pat/i, $sub ];
}
}
$self->{_phonetic_rules} = \@rules;
}
# Safe-text character class (alphabet_chars extends a-zA-Z)
my $extra = $loc->{alphabet_chars} || '';
my $safe_extra = quotemeta($extra);
$self->{_safe_re} = qr/[^a-zA-Z${safe_extra}0-9&.,_\-;:()\s]/;
$self->{_letter_re} = qr/[a-zA-Z${safe_extra}]/;
my @splitters = @{ $loc->{word_splitters} || [ "'", "\x{2019}", "\x{2018}", "\x{2032}", "\x{02BC}", "-" ] };
my $split_chars = join '', map { quotemeta($_) } @splitters;
$self->{_splitter_re} = qr/[$split_chars]/;
# Combined html_entities: universal + locale-specific extras
$self->{_html_entities} = {
# Universal entities
'&' => '&', '<' => '<',
'>' => '>', '"' => '"',
''' => "'", ' ' => ' ',
'€' => "\x{20AC}", '«' => "\x{AB}",
'»' => "\x{BB}", '‘' => "\x{2018}",
'’' => "\x{2019}", '“' => "\x{201C}",
'”' => "\x{201D}", '…' => "\x{2026}",
'–' => "\x{2013}", '—' => "\x{2014}",
'•' => "\x{2022}", '™' => "\x{2122}",
'©' => "\x{00A9}", '®' => "\x{00AE}",
# Locale-specific extras (override/extend universals)
%{ $loc->{html_entities} || {} },
};
return $self;
}
# =======================================================
# PUBLIC API — UTF-8 Encoding / Decoding & String Operations
# =======================================================
# -------------------------------------------------------
# utf_encode: Converts a Perl Unicode string into raw UTF-8 octets (bytes).
# my $bytes = $lang->utf_encode($string);
# -------------------------------------------------------
sub utf_encode {
my ( $self, $string ) = @_;
return unless defined $string;
utf8::encode($string) if utf8::is_utf8($string);
return $string;
}
# -------------------------------------------------------
# utf_decode: Decodes raw UTF-8 bytes into a Perl Unicode character string.
# my $chars = $lang->utf_decode($string);
# -------------------------------------------------------
sub utf_decode {
my ( $self, $string ) = @_;
return unless defined $string;
utf8::decode($string) unless utf8::is_utf8($string);
return $string;
}
# -------------------------------------------------------
# Locale-aware uppercase.
# Applies uc_map substitutions before Perl's CORE::uc().
# my $upper = $lang->uc($string);
# -------------------------------------------------------
sub uc {
my ( $self, $string ) = @_;
return unless defined $string;
$string = $self->utf_decode($string);
if ( my $re = $self->{_uc_re} ) {
my $uc_map = $self->{_locale}{uc_map};
$string =~ s/$re/$uc_map->{$1}/ge;
}
return CORE::uc($string);
}
# -------------------------------------------------------
# Locale-aware lowercase.
# Applies lc_map substitutions before Perl's CORE::lc().
# my $lower = $lang->lc($string);
# -------------------------------------------------------
sub lc {
my ( $self, $string ) = @_;
return unless defined $string;
$string = $self->utf_decode($string);
if ( my $re = $self->{_lc_re} ) {
my $lc_map = $self->{_locale}{lc_map};
$string =~ s/$re/$lc_map->{$1}/ge;
}
return CORE::lc($string);
}
# -------------------------------------------------------
# Converts search query string into a locale-aware regex pattern.
# Replaces locale-specific casing characters with regex match patterns.
# my $pattern = $lang->search_pattern($query);
# -------------------------------------------------------
sub search_pattern {
my ( $self, $string ) = @_;
return '' unless defined $string;
$string = $self->utf_decode($string);
if ( my $re = $self->{_search_re} ) {
my $sm = $self->{_search_map};
$string =~ s/$re/$sm->{$1}/ge;
}
return $string;
}
# -------------------------------------------------------
# Performs regex search matching of search pattern inside target text string.
# Does not re-normalize $aranan; performs matching directly.
# my $bool = $lang->search_regex($string, $aranan);
# -------------------------------------------------------
sub search_regex {
my ( $self, $string, $aranan ) = @_;
return 0 unless defined $string && defined $aranan && length($aranan);
$string = $self->utf_decode($string);
lib/AmberDB/Locale.pm view on Meta::CPAN
}
$mil_part =~ s/\s+$//;
$str = "$mil_part $million" . ( $str ? " $str" : '' );
}
# Billions (1,000,000,000 - 999,999,999,999)
if ($bil1_d || $bil10_d || $bil100_d) {
my $bil_part = '';
$bil_part .= $ones->[$bil1_d-1] . ' ' if $bil1_d && $bil1_d > 0;
$bil_part = $tens->[$bil10_d-1] . " $bil_part" if $bil10_d && $bil10_d > 0;
if ($bil100_d && $bil100_d > 0) {
my $h = $bil100_d == 1 ? $hundred : $ones->[$bil100_d-1] . " $hundred";
$bil_part = "$h $bil_part";
}
$bil_part =~ s/\s+$//;
$str = "$bil_part $billion" . ( $str ? " $str" : '' );
}
$str =~ s/\s+/ /g;
$str =~ s/^\s+|\s+$//g;
$str_main = "$str " . ( $currency->{main} || '' );
$str_main =~ s/\s+/ /g;
$str_main =~ s/\s+$//;
}
my $result = join ' ', grep { defined && length } ( $str_main, $str_sub );
$result = $numbers->{zero} unless length($result);
if ( $is_negative && $result ne $numbers->{zero} ) {
$result = "$negative_prefix $result";
}
return $result;
}
# -------------------------------------------------------
# UTF-8 character-based substring (character count, not byte count).
# Safe against cutting UTF-8 multibyte characters in half.
#
# Signatures:
# $lang->substring($string, $length) # offset=0
# $lang->substring($string, $offset, $length) # explicit offset
# -------------------------------------------------------
sub substring {
my $self = shift;
my $string = shift;
return '' unless defined $string;
my ( $offset, $length );
if ( @_ == 1 ) {
$offset = 0;
$length = $_[0];
}
else {
( $offset, $length ) = @_;
}
$length //= length($string);
return $string if $offset == 0 && length($string) <= $length;
my $is_raw = !utf8::is_utf8($string);
my $ustr = $self->utf_decode($string);
my $cut = substr( $ustr, $offset, $length );
return $is_raw ? $self->utf_encode($cut) : $cut;
}
# -------------------------------------------------------
# Month names list accessor for current locale (12 elements)
# my $months = $lang->months();
# -------------------------------------------------------
sub months {
my ($self) = @_;
return $self->{_locale}{months} || [
"January", "February", "March", "April", "May", "June",
"July", "August", "September", "October", "November", "December"
];
}
# -------------------------------------------------------
# Day names list accessor for current locale (7 elements, Sun..Sat)
# my $days = $lang->days();
# -------------------------------------------------------
sub days {
my ($self) = @_;
return $self->{_locale}{days} || [
"Sunday", "Monday", "Tuesday", "Wednesday",
"Thursday", "Friday", "Saturday"
];
}
# -------------------------------------------------------
# Format numeric value according to locale conventions.
#
# my $formatted = $lang->format_number(1234567.89); # "1.234.567,89" (tr)
# my $formatted = $lang->format_number(1234567.89, decimals=>0); # "1.234.568"
# my $formatted = $lang->format_number(1234567.89, decimals=>3); # "1.234.567,890"
# -------------------------------------------------------
sub format_number {
my ( $self, $num, %opts ) = @_;
return '' unless defined $num && length($num);
$num = $self->normalize_num($num);
$num =~ s/^\s+|\s+$//g;
return '0' if $num eq '';
my $fmt = $self->{_locale}{number_format} || {};
my $dec_sep = $opts{decimal_sep} // $fmt->{decimal_sep} // '.';
my $group_sep = $opts{group_sep} // $fmt->{group_sep} // ',';
my $group_size = $fmt->{group_size} || 3;
my $is_neg = 0;
if ( $num =~ s/^\s*-// ) {
$is_neg = 1;
}
# Normalize input separator if string contains commas/dots
$num =~ s/,/./g unless $dec_sep eq '.';
my $decimals = $opts{decimals};
if ( !defined $decimals ) {
if ( $num =~ /\.(\d+)/ ) {
lib/AmberDB/Locale.pm view on Meta::CPAN
# 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
AmberDB::Locale - Multilingual text processing, collation, number/currency formatting, and search normalization engine
=head1 SYNOPSIS
# =========================================================================
# 1. DIRECT USAGE VIA AMBERDB INSTANCE ($adb inherits AmberDB::Locale):
# Reads active language from config (default is 'gb' or configured language)
# =========================================================================
my $adb = AmberDB->new(cfg => { language => "gb" });
# Case Conversions & Comparison
my $upper = $adb->uc("ığdır"); # "IĞDIR"
my $lower = $adb->lc("Ä°STANBUL"); # "istanbul"
my $title = $adb->ucfirst("istanbul büyükşehir"); # "İstanbul Büyükşehir"
my $folded = $adb->fold("Ä°STANBUL"); # "istanbul"
my $same = $adb->ieq("Ä°stanbul", "istanbul"); # 1
# Unicode Collation Algorithm (UCA) Sorting
my @sorted = $adb->sort(["İzmir", "Ankara", "Van", "Şanlıurfa", "Bursa", "Çanakkale"]);
# => ("Ankara", "Bursa", "Çanakkale", "İzmir", "Şanlıurfa", "Van")
# Text Normalization & Transliteration (Turkish rules: ü -> u, ç -> c)
my $clean = $adb->normalize("<p>Kâr & zarar çizelgesi</p>"); # "Kar zarar cizelgesi"
my $ascii = $adb->to_ascii("müller"); # "muller" (Turkish: ü -> u)
my $slug = $adb->to_ascii("İstanbul Kâr & Zarar!", 1); # "istanbul_kar_zarar"
# UTF-8 Safe Substring (character-based, safe for multibyte chars)
my $sub = $adb->substring("Çanakkale", 0, 4); # "Çana"
# Number to Written Text (Invoices / Cheques)
my $text = $adb->num2text(1234.56);
# => "Bin İki Yüz Otuz Dört TL Elli Altı KR" (Note: "Bin", not "Bir Bin")
# Number & Currency Formatting
my $num = $adb->format_number(1234567.89); # "1.234.567,89"
my $curr = $adb->format_currency(1234.50, "EUR"); # "1.234,50 €"
# Date Formatting & Parsing
my $date = $adb->format_date(time(), "full"); # "Cuma, 28 AÄŸustos 2026"
my $ep = $adb->parse_date("28.08.2026"); # Unix timestamp
# Pluralization (CLDR)
my $msg = $adb->plural(5, { one => "{count} ürün", other => "{count} ürün" });
# Search Token Normalization
my $norm = $adb->normalize_word("Türkiye'de", 1); # "turkiye turkiyede"
# =========================================================================
# 2. CROSS-LANGUAGE COMPARISON & STANDALONE USAGE:
# =========================================================================
use AmberDB::Locale;
my $tr = AmberDB::Locale->new(language => "tr");
my $de = AmberDB::Locale->new(language => "de");
my $en = AmberDB::Locale->new(language => "en");
my $fr = AmberDB::Locale->new(language => "fr");
my $ru = AmberDB::Locale->new(language => "ru");
( run in 0.691 second using v1.01-cache-2.11-cpan-364913b4093 )