##---------------------------------------------------------------------------- ## Unicode Locale Identifier - ~/lib/Locale/Unicode/Data.pm ## Version v1.4.0 ## Copyright(c) 2025 DEGUEST Pte. Ltd. ## Author: Jacques Deguest ## Created 2024/06/15 ## Modified 2025/03/21 ## All rights reserved ## ## ## This program is free software; you can redistribute it and/or modify it ## under the same terms as Perl itself. ##---------------------------------------------------------------------------- package Locale::Unicode::Data; BEGIN { use v5.10.1; use strict; use warnings; use warnings::register; use vars qw( $ERROR $VERSION $DEBUG $FATAL_EXCEPTIONS $CLDR_VERSION $DB_FILE $DBH $STHS ); use version; use Exporter (); use DBD::SQLite; use DBI qw( :sql_types ); use Encode (); use File::Spec; use JSON; use Locale::Unicode v0.3.5; use Scalar::Util (); use Want; use constant { HAS_CONSTANTS => ( version->parse( $DBD::SQLite::VERSION ) >= 1.48 ? 1 : 0 ), MISSING_AUTO_UTF8_DECODING => ( version->parse( $DBD::SQLite::VERSION ) < 1.68 ? 1 : 0 ), }; our $CLDR_VERSION = '47.0'; our $DBH = {}; our $STHS = {}; our $VERSION = 'v1.4.0'; }; use strict; use warnings; { my( $vol, $parent, $file ) = File::Spec->splitpath(__FILE__); $DB_FILE = File::Spec->catpath( $vol, $parent, 'unicode_cldr.sqlite3' ); unless( File::Spec->file_name_is_absolute( $DB_FILE ) ) { $DB_FILE = File::Spec->rel2abs( $DB_FILE ); } } sub new { my $this = shift( @_ ); my $self = bless( {} => ( ref( $this ) || $this ) ); $self->{datafile} = $DB_FILE; $self->{decode_sql_arrays} = 1; $self->{extend_timezones_cities} = 1; $self->{fatal} = ( $FATAL_EXCEPTIONS // 0 ); my @args = @_; if( scalar( @args ) == 1 && defined( $args[0] ) && ref( $args[0] ) eq 'HASH' ) { my $opts = shift( @args ); @args = %$opts; } elsif( ( scalar( @args ) % 2 ) ) { return( $self->error( sprintf( "Uneven number of parameters provided (%d). Should receive key => value pairs. Parameters provided are: %s", scalar( @args ), join( ', ', @args ) ) ) ); } for( my $i = 0; $i < scalar( @args ); $i += 2 ) { if( $args[$i] eq 'fatal' ) { $self->{fatal} = $args[$i + 1]; last; } } # Then, if the user provided with an hash or hash reference of options, we apply them for( my $i = 0; $i < scalar( @args ); $i++ ) { my $name = $args[ $i ]; my $val = $args[ ++$i ]; my $meth = $self->can( $name ); if( !defined( $meth ) ) { return( $self->error( "Unknown method \"${meth}\" provided." ) ); } elsif( !defined( $meth->( $self, $val ) ) ) { if( defined( $val ) && $self->error ) { return( $self->pass_error ); } } } my $file = $self->{datafile} || return( $self->error( "No SQLite data file set." ) ); my $dbh = $self->_dbh || return( $self->pass_error ); $self->{_dbh} = $dbh; return( $self ); } sub alias { return( shift->_fetch_one({ id => 'get_alias', field => 'alias', table => 'aliases', requires => [qw( type )], has_array => [qw( replacement )], }, @_ ) ); } sub aliases { return( shift->_fetch_all({ id => 'aliases', table => 'aliases', by => [qw( type )], has_array => [qw( replacement )], }, @_ ) ); } sub annotation { return( shift->_fetch_one({ id => 'get_annotation', field => 'annotation', table => 'annotations', requires => [qw( locale )], has_array => [qw( defaults )], }, @_ ) ); } sub annotations { return( shift->_fetch_all({ id => 'annotations', table => 'annotations', by => [qw( locale )], has_array => [qw( defaults )], }, @_ ) ); } sub bcp47_currency { return( shift->_fetch_one({ id => 'get_bcp47_currency', field => 'currid', table => 'bcp47_currencies', }, @_ ) ); } sub bcp47_currencies { return( shift->_fetch_all({ id => 'bcp47_currencies', table => 'bcp47_currencies', by => [qw( code is_obsolete )], }, @_ ) ); } sub bcp47_extension { return( shift->_fetch_one({ id => 'get_bcp47_extension', field => 'extension', table => 'bcp47_extensions', }, @_ ) ); } sub bcp47_extensions { return( shift->_fetch_all({ id => 'bcp47_extensions', table => 'bcp47_extensions', by => [qw( extension deprecated )], }, @_ ) ); } sub bcp47_timezone { return( shift->_fetch_one({ id => 'get_bcp47_timezone', field => 'tzid', table => 'bcp47_timezones', has_array => [qw( alias )], }, @_ ) ); } sub bcp47_timezones { return( shift->_fetch_all({ id => 'bcp47_timezones', table => 'bcp47_timezones', by => [qw( deprecated )], has_array => [qw( alias )], }, @_ ) ); } sub bcp47_value { return( shift->_fetch_one({ id => 'get_bcp47_value', field => 'value', table => 'bcp47_values', }, @_ ) ); } sub bcp47_values { return( shift->_fetch_all({ id => 'bcp47_values', table => 'bcp47_values', by => [qw( category extension )], }, @_ ) ); } sub calendar { return( shift->_fetch_one({ id => 'get_calendar', field => 'calendar', table => 'calendars', }, @_ ) ); } sub calendars { return( shift->_fetch_all({ id => 'calendars', table => 'calendars', by => [qw( calendar system inherits )], }, @_ ) ); } sub calendar_append_format { return( shift->_fetch_one({ id => 'get_calendar_append_format', field => 'format_id', table => 'calendar_append_formats', requires => [qw( locale calendar )], }, @_ ) ); } sub calendar_append_formats { return( shift->_fetch_all({ id => 'calendar_append_formats', table => 'calendar_append_formats', by => [qw( locale calendar )], }, @_ ) ); } sub calendar_available_format { return( shift->_fetch_one({ id => 'get_calendar_available_format', field => 'format_id', table => 'calendar_available_formats', requires => [qw( locale calendar count alt )], default => { count => undef, alt => undef }, }, @_ ) ); } sub calendar_available_formats { return( shift->_fetch_all({ id => 'calendar_available_formats', table => 'calendar_available_formats', by => [qw( locale calendar count alt )], }, @_ ) ); } sub calendar_cyclic_l10n { return( shift->_fetch_one({ id => 'get_calendar_cyclic_l10n', field => 'format_id', table => 'calendar_cyclics_l10n', requires => [qw( locale calendar format_set format_type format_length )], }, @_ ) ); } sub calendar_cyclics_l10n { return( shift->_fetch_all({ id => 'calendar_cyclics_l10n', table => 'calendar_cyclics_l10n', by => [qw( locale calendar format_set format_type format_length )], }, @_ ) ); } sub calendar_datetime_format { return( shift->_fetch_one({ id => 'get_calendar_datetime_format', field => 'format_type', table => 'calendar_datetime_formats', requires => [qw( locale calendar format_length )], }, @_ ) ); } sub calendar_datetime_formats { return( shift->_fetch_all({ id => 'calendar_datetime_formats', table => 'calendar_datetime_formats', by => [qw( locale calendar )], }, @_ ) ); } sub calendar_era { my $self = shift( @_ ); my $opts = $self->_get_args_as_hash( @_ ); $opts->{calendar} || return( $self->error( "No calendar ID was provided." ) ); if( $opts->{calendar} !~ /^[a-zA-Z]+(?:\-[a-zA-Z]+)*$/ ) { return( $self->error( "Calendar ID provided '$opts->{calendar}' contains illegal characters." ) ); } my $sql_arrays_in = [qw( aliases )]; my $sth; local $@; if( $opts->{sequence} ) { if( defined( $opts->{sequence} ) && $opts->{sequence} !~ /^\d+$/ ) { return( $self->error( "The calendar era sequence provided (", ( $opts->{sequence} // 'undef' ), ") does not look like an integer." ) ); } unless( $sth = $self->_get_cached_statement( 'calendar_era_with_sequence' ) ) { my $dbh = $self->_dbh || return( $self->pass_error ); $sth = eval { $dbh->prepare( "SELECT * FROM calendar_eras WHERE calendar = ? AND sequence = ?" ) } || return( $self->error( "Unable to prepare SQL query to retrieve calendar era information for a given calendar and sequence: ", ( $@ || $dbh->errstr ) ) ); $self->_set_cached_statement( calendar_era_with_sequence => $sth ); } eval { $sth->execute( @$opts{qw( calendar sequence )} ) } || return( $self->error( "Error executing SQL query '$sth->{Statement}' to retrieve calendar era information for a given calendar and sequence: ", ( $@ || $sth->errstr ) ) ); } elsif( $opts->{code} ) { if( defined( $opts->{code} ) && $opts->{code} !~ /^[a-zA-Z]+(?:\-[a-zA-Z]+)*$/ ) { return( $self->error( "The calendar era code provided (", ( $opts->{code} // 'undef' ), ") contains illegal characters." ) ); } unless( $sth = $self->_get_cached_statement( 'calendar_era_with_code' ) ) { my $dbh = $self->_dbh || return( $self->pass_error ); $sth = eval { $dbh->prepare( "SELECT * FROM calendar_eras WHERE calendar = ? AND code = ?" ) } || return( $self->error( "Unable to prepare SQL query to retrieve calendar era information for a given calendar and code: ", ( $@ || $dbh->errstr ) ) ); $self->_set_cached_statement( calendar_era_with_code => $sth ); } eval { $sth->execute( @$opts{qw( calendar code )} ) } || return( $self->error( "Error executing SQL query '$sth->{Statement}' to retrieve calendar era information for a given calendar and code: ", ( $@ || $sth->errstr ) ) ); } else { return( $self->error( "No sequence or code parameter provided to retrieve specific era for calendar $opts->{calendar}" ) ); } my $ref = $sth->fetchrow_hashref; $self->_decode_utf8( $ref ) if( MISSING_AUTO_UTF8_DECODING ); $self->_decode_sql_arrays( $sql_arrays_in, $ref ) if( $self->{decode_sql_arrays} ); return( $ref ); } sub calendar_eras { my $self = shift( @_ ); my $opts = $self->_get_args_as_hash( @_ ); my $sql_arrays_in = [qw( aliases )]; my $sth; local $@; if( $opts->{calendar} ) { unless( $sth = $self->_get_cached_statement( 'calendar_eras_with_calendar' ) ) { my $dbh = $self->_dbh || return( $self->pass_error ); $sth = eval { $dbh->prepare( "SELECT * FROM calendar_eras WHERE calendar = ?" ) } || return( $self->error( "Unable to prepare SQL query to retrieve all calendar eras information for a given calendar': ", ( $@ || $dbh->errstr ) ) ); $self->_set_cached_statement( calendar_eras_with_calendar => $sth ); } } else { unless( $sth = $self->_get_cached_statement( 'calendar_eras' ) ) { my $dbh = $self->_dbh || return( $self->pass_error ); $sth = eval { $dbh->prepare( "SELECT * FROM calendar_eras" ) } || return( $self->error( "Unable to prepare SQL query to retrieve all calendar eras information: ", ( $@ || $dbh->errstr ) ) ); $self->_set_cached_statement( calendar_eras => $sth ); } } eval { $sth->execute( length( $opts->{calendar} // '' ) ? $opts->{calendar} : () ) } || return( $self->error( "Error executing SQL query '$sth->{Statement}' to retrieve all calendar eras". ( $opts->{calendar} ? " with calendar '$opts->{calendar}'" : '' ), ": ", ( $@ || $sth->errstr ) ) ); my $all = $sth->fetchall_arrayref({}); $self->_decode_utf8( $all ) if( MISSING_AUTO_UTF8_DECODING ); $self->_decode_sql_arrays( $sql_arrays_in, $all ) if( $self->{decode_sql_arrays} ); return( $all ); } sub calendar_era_l10n { return( shift->_fetch_one({ id => 'get_calendar_era_l10n', field => 'era_id', table => 'calendar_eras_l10n', requires => [qw( locale calendar era_width alt )], default => { alt => undef }, }, @_ ) ); } sub calendar_eras_l10n { return( shift->_fetch_all({ id => 'calendar_eras_l10n', table => 'calendar_eras_l10n', by => [qw( locale calendar era_width alt )], order => 'era_id', }, @_ ) ); } sub calendar_format_l10n { return( shift->_fetch_one({ id => 'get_calendar_format_l10n', field => 'format_length', table => 'calendar_formats_l10n', requires => [qw( locale calendar format_type )], }, @_ ) ); } sub calendar_formats_l10n { return( shift->_fetch_all({ id => 'calendar_formats_l10n', table => 'calendar_formats_l10n', by => [qw( locale calendar format_type format_length alt )], }, @_ ) ); } sub calendar_interval_format { return( shift->_fetch_one({ id => 'get_calendar_interval_format', field => 'format_id', table => 'calendar_interval_formats', requires => [qw( locale calendar greatest_diff_id alt )], default => { alt => undef }, }, @_ ) ); } sub calendar_interval_formats { return( shift->_fetch_all({ id => 'calendar_interval_formats', table => 'calendar_interval_formats', by => [qw( locale calendar greatest_diff_id alt )], }, @_ ) ); } sub calendar_l10n { return( shift->_fetch_one({ id => 'get_calendar_l10n', field => 'calendar', table => 'calendars_l10n', requires => [qw( locale )], default => { count => undef }, }, @_ ) ); } sub calendars_l10n { return( shift->_fetch_all({ id => 'calendars_l10n', table => 'calendars_l10n', by => [qw( locale )], }, @_ ) ); } sub calendar_term { return( shift->_fetch_one({ # id => 'get_calendar_term', field => 'term_name', table => 'calendar_terms', requires => [qw( locale calendar term_context term_width alt yeartype )], default => { alt => undef, yeartype => undef }, }, @_ ) ); } # NOTE: no calendar_term() method, because filtering would return more than one element sub calendar_terms { return( shift->_fetch_all({ id => 'calendars', table => 'calendar_terms', by => [qw( locale calendar term_type term_context term_width alt yeartype )], }, @_ ) ); } sub casing { return( shift->_fetch_one({ id => 'get_casing', field => 'token', table => 'casings', requires => [qw( locale )], }, @_ ) ); } sub casings { return( shift->_fetch_all({ id => 'casings', table => 'casings', by => [qw( locale )], }, @_ ) ); } sub cldr_built { return( shift->_get_metadata( 'built_on' ) ); } sub cldr_maintainer { return( shift->_get_metadata( 'maintainer' ) ); } sub cldr_version { return( shift->_get_metadata( 'cldr_version' ) ); } sub code_mapping { return( shift->_fetch_one({ id => 'get_code_mapping', field => 'code', table => 'code_mappings', }, @_ ) ); } sub code_mappings { return( shift->_fetch_all({ id => 'code_mappings', table => 'code_mappings', by => [qw( alpha3 numeric fips10 type )], }, @_ ) ); } sub collation { return( shift->_fetch_one({ id => 'get_collation', field => 'collation', table => 'collations', }, @_ ) ); } sub collations { return( shift->_fetch_all({ id => 'collations', table => 'collations', by => [qw( collation description )], # Important, because this is a view, and without explicitly defining the ordering field, it would fall back to rowid, which does not exist in view and would result in a fatal exception. order => 'collation', }, @_ ) ); } sub collation_l10n { return( shift->_fetch_one({ id => 'get_collation_l10n', field => 'collation', table => 'collations_l10n', requires => [qw( locale )], }, @_ ) ); } sub collations_l10n { return( shift->_fetch_all({ id => 'collations_l10n', table => 'collations_l10n', by => [qw( locale collation locale_name )], }, @_ ) ); } sub currency { return( shift->_fetch_one({ id => 'get_currency', field => 'currency', table => 'currencies', }, @_ ) ); } sub currencies { return( shift->_fetch_all({ id => 'currencies', table => 'currencies', by => [qw( is_obsolete )], has_status => 1, }, @_ ) ); } sub currency_info { return( shift->_fetch_one({ id => 'get_currency_info', field => 'currency', table => 'currencies_info', requires => [qw( territory )], }, @_ ) ); } sub currencies_info { return( shift->_fetch_all({ id => 'currencies', table => 'currencies_info', by => [qw( territory currency )], }, @_ ) ); } sub currency_l10n { return( shift->_fetch_one({ id => 'get_currency_l10n', field => 'currency', table => 'currencies_l10n', requires => [qw( locale count )], default => { count => undef }, }, @_ ) ); } sub currencies_l10n { return( shift->_fetch_all({ id => 'currencies_l10n', table => 'currencies_l10n', by => [qw( locale currency count )], }, @_ ) ); } sub database_handler { return( Scalar::Util::blessed( $_[0] ) ? shift->{_dbh} : undef ); } sub datafile { return( shift->_set_get_prop( 'datafile', @_ ) ); } sub date_field_l10n { return( shift->_fetch_one({ id => 'get_date_field_l10n', field => 'relative', table => 'date_fields_l10n', requires => [qw( locale field_type field_length )], }, @_ ) ); } sub date_fields_l10n { return( shift->_fetch_all({ id => 'date_fields_l10n', table => 'date_fields_l10n', by => [qw( locale field_type field_length )], }, @_ ) ); } sub date_term { return( shift->_fetch_one({ id => 'get_date_term', field => 'term_type', table => 'date_terms', requires => [qw( locale term_length )], }, @_ ) ); } sub date_terms { return( shift->_fetch_all({ id => 'date_terms', table => 'date_terms', by => [qw( locale term_type term_length )], }, @_ ) ); } sub day_period { return( shift->_fetch_one({ id => 'get_day_period', field => 'day_period', table => 'day_periods', requires => [qw( locale )], }, @_ ) ); } sub day_periods { return( shift->_fetch_all({ id => 'day_periods', table => 'day_periods', by => [qw( locale day_period )], }, @_ ) ); } sub decode_sql_arrays { return( shift->_set_get_prop({ field => 'decode_sql_arrays', type => 'boolean', }, @_ ) ); } sub error { my $self = shift( @_ ); if( @_ ) { my $msg = join( '', map( ( ref( $_ ) eq 'CODE' ) ? $_->() : $_, @_ ) ); $self->{error} = $ERROR = Locale::Unicode::Data::Exception->new({ skip_frames => 1, message => $msg, }); if( $self->fatal ) { die( $self->{error} ); } else { warn( $msg ) if( warnings::enabled() ); rreturn( Locale::Unicode::Data::NullObject->new ) if( Want::want( 'OBJECT' ) ); return; } } return( ref( $self ) ? $self->{error} : $ERROR ); } sub extend_timezones_cities { return( shift->_set_get_prop({ field => 'extend_timezones_cities', type => 'boolean', }, @_ ) ); } sub fatal { return( shift->_set_get_prop( 'fatal', @_ ) ); } sub interval_formats { my $self = shift( @_ ); my $opts = $self->_get_args_as_hash( @_ ); my $locale = $opts->{locale} || return( $self->error( "No locale provided to get all the interval formats." ) ); my $cal_id = $opts->{calendar} || return( $self->error( "No calendar ID provided to get all the interval formats." ) ); my $all = $self->calendar_interval_formats( locale => $locale, calendar => $cal_id, ) || return( $self->pass_error ); my $formats = {}; foreach my $ref ( @$all ) { $formats->{ $ref->{format_id} } ||= []; push( @{$formats->{ $ref->{format_id} }}, $ref->{greatest_diff_id} ); } return( $formats ); } sub l10n { my $self = shift( @_ ); my $opts = $self->_get_args_as_hash( @_ ); my $type = $opts->{type} || return( $self->error( "No localisation type was provided." ) ); my $type_to_table = { annotation => { table => 'annotations', field => 'annotation', has_array => [qw( defaults )], }, calendar_append_format => { table => 'calendar_append_formats', field => 'format_id', requires => [qw( locale calendar )], }, calendar_available_format => { table => 'calendar_available_formats', field => 'format_id', requires => [qw( locale calendar )], }, calendar_cyclic => { table => 'calendar_cyclics_l10n', field => 'format_id', requires => [qw( locale calendar format_set )], }, calendar_era => { table => 'calendar_eras_l10n', field => 'era_id', requires => [qw( locale calendar era_width )], }, calendar_format => { table => 'calendar_formats_l10n', field => 'format_id', requires => [qw( locale calendar )], }, calendar_interval_format => { table => 'calendar_interval_formats', field => 'format_id', requires => [qw( locale calendar )], }, calendar_term => { table => 'calendar_terms', field => 'term_name', requires => [qw( locale calendar )], }, casing => { table => 'casings', field => 'token', }, currency => { table => 'currencies_l10n', field => 'currency', }, date_field => { table => 'date_fields_l10n', field => 'relative', requires => [qw( locale field_type )], }, locale => { table => 'locales_l10n', field => 'locale_id', }, number_format => { table => 'number_formats_l10n', field => 'format_id', requires => [qw( locale number_type )], }, number_symbol => { table => 'number_symbols_l10n', field => 'property', }, script => { table => 'scripts_l10n', field => 'script', }, subdivision => { table => 'subdivisions_l10n', field => 'subdivision', }, territory => { table => 'territories_l10n', field => 'territory', }, unit => { table => 'units_l10n', field => 'unit_id', }, variant => { table => 'variants_l10n', field => 'variant', }, }; $type_to_table->{era} = $type_to_table->{calendar_era}; $type_to_table->{available} = $type_to_table->{calendar_available_format}; $type_to_table->{append} = $type_to_table->{calendar_append_format}; $type_to_table->{cyclic} = $type_to_table->{calendar_cyclics_l10n}; $type_to_table->{field} = $type_to_table->{date_field}; $type_to_table->{interval} = $type_to_table->{calendar_interval_format}; $type_to_table->{symbol} = $type_to_table->{number_symbol}; if( !exists( $type_to_table->{ $type } ) ) { return( $self->error( "Unknown localisation type '${type}'" ) ); } my $table = $type_to_table->{ $type }->{table}; my $field = $type_to_table->{ $type }->{field}; my $key; if( exists( $opts->{key} ) ) { $key = $opts->{key}; } elsif( exists( $opts->{ $field } ) ) { $key = $opts->{ $field }; } return( $self->error( "No localisation key was provided." ) ) if( !defined( $key ) || !length( $key // '' ) ); my $requires = exists( $type_to_table->{ $type }->{requires} ) ? $type_to_table->{ $type }->{requires} : [qw( locale )]; foreach( @$requires ) { if( !exists( $opts->{ $_ } ) || !defined( $opts->{ $_ } ) || !length( $opts->{ $_ } // '' ) ) { return( $self->error( "No value provided for argument '$_' to retrieve localised data from table ${table}" ) ); } } local $@; my $sth; my $sth_id = "l10n_${table}" . ( scalar( @$requires ) ? '_' . join( '_', @$requires ) : '' ); unless( $sth = $self->_get_cached_statement( $sth_id ) ) { my $dbh = $self->_dbh || return( $self->pass_error ); $sth = eval { $dbh->prepare( "SELECT * FROM ${table} WHERE ${field} = ?" . ( scalar( @$requires ) ? ' AND ' . join( ' AND ', map( "$_ = ?", @$requires ) ) : '' ) . ' ORDER BY rowid' ); } || return( $self->error( "Unable to prepare SQL query to retrieve data from the table ${table} with field ${field}: ", ( $@ || $dbh->errstr ) ) ); $self->_set_cached_statement( $sth_id => $sth ); } eval { $sth->execute( $key, @$opts{ @$requires } ); } || return( $self->error( "Error executing SQL statement to retrieve data from the table ${table} with field ${field} and arguments '", join( "', '", @$requires ), "': ", ( $@ || $sth->errstr ), " with SQL query: ", $sth->{Statement} ) ); my $all = $sth->fetchall_arrayref({}); $self->_decode_utf8( $all ) if( MISSING_AUTO_UTF8_DECODING ); if( exists( $type_to_table->{ $type }->{has_array} ) && $self->{decode_sql_arrays} ) { $self->_decode_sql_arrays( $type_to_table->{ $type }->{has_array}, $all ); } return( $all ); } sub language { return( shift->_fetch_one({ id => 'get_language', field => 'language', table => 'languages', has_array => [qw( scripts territories )], }, @_ ) ); } sub languages { return( shift->_fetch_all({ id => 'languages', table => 'languages', by => [qw( parent alt )], has_status => 1, has_array => [qw( scripts territories )], }, @_ ) ); } sub language_population { return( shift->_fetch_one({ id => 'get_language_population', field => 'territory', table => 'language_population', multi => 1, }, @_ ) ); } sub language_populations { return( shift->_fetch_all({ id => 'language_population', table => 'language_population', has_status => 'official_status', }, @_ ) ); } sub likely_subtag { return( shift->_fetch_one({ id => 'get_likely_subtags', field => 'locale', table => 'likely_subtags', }, @_ ) ); } sub likely_subtags { return( shift->_fetch_all({ id => 'likely_subtags', table => 'likely_subtags', }, @_ ) ); } sub locale { return( shift->_fetch_one({ id => 'get_locale', field => 'locale', table => 'locales', has_array => [qw( collations )], }, @_ ) ); } sub locales { return( shift->_fetch_all({ id => 'locales', table => 'locales', has_status => 1, has_array => [qw( collations )], }, @_ ) ); } sub locale_l10n { return( shift->_fetch_one({ id => 'get_locale_l10n', field => 'locale_id', table => 'locales_l10n', requires => [qw( locale alt )], default => { alt => undef }, }, @_ ) ); } sub locales_l10n { return( shift->_fetch_all({ id => 'locales_l10n', table => 'locales_l10n', by => [qw( locale locale_id alt )], }, @_ ) ); } sub locales_info { return( shift->_fetch_one({ id => 'get_locales_info', field => 'property', table => 'locales_info', requires => [qw( locale )], }, @_ ) ); } sub locales_infos { return( shift->_fetch_all({ id => 'locales_info', table => 'locales_info', }, @_ ) ); } sub locale_number_system { return( shift->_fetch_one({ id => 'get_locale_number_system', field => 'locale', table => 'locale_number_systems', requires => [qw()], }, @_ ) ); } sub locale_number_systems { return( shift->_fetch_all({ id => 'locale_number_systems', table => 'locale_number_systems', by => [qw( number_system native traditional finance )], }, @_ ) ); } # sub make_inheritance_tree { my $self = shift( @_ ); my $locale = $self->_locale_object( shift( @_ ) ) || return( $self->pass_error ); $locale = $self->_locale_object( $locale->clone->base ) || return( $self->pass_error ); my $tree = ["$locale"]; my $ref; if( ( $ref = $self->locale( locale => $locale ) ) && $ref->{parent} ) { my $tree2 = $self->make_inheritance_tree( $ref->{parent} ) || return( $self->pass_error ); push( @$tree, @$tree2 ); return( $tree ); } # The locale has something like en-Latn-US, we need to save in the tree en-US if( $locale->territory && ( $locale->script || $locale->variant ) ) { my $clone = $locale->clone; $clone->script( undef ); $clone->variant( undef ); push( @$tree, "$clone" ); if( ( $ref = $self->locale( locale => $clone ) ) && $ref->{parent} ) { my $tree2 = $self->make_inheritance_tree( $ref->{parent} ) || return( $self->pass_error ); push( @$tree, @$tree2 ); return( $tree ); } } # "The default search chain is slighly different for multiple variants. In that case, the inheritance chain covers all combinations of variants, with longest number of variants first, and otherwise in alphabetical order." # Check if there are more than one variants, in which case, we add each variation by removing one variant at each iteration my $variants = $locale->variants; if( scalar( @$variants ) ) { if( scalar( @$variants ) > 1 ) { local $" = '-'; my $seen = { "@$variants" => 1 }; # We use permutation to produce all possible combinations # Credits: my $permute; $permute = sub { my( $list, $n ) = @_; return( map( [$_], @$list ) ) if( $n <= 1 ); my @comb; for my $i ( 0 .. $#$list ) { my @rest = @$list; my $val = splice( @rest, $i, 1 ); push( @comb, [$val, @$_] ) for( $permute->( \@rest, $n - 1 ) ); } return( @comb ); }; while( scalar( @$variants ) ) { my @variations = $permute->( $variants, scalar( @$variants ) ); foreach my $ref ( @variations ) { if( scalar( keys( %$seen ) ) ) { # We skip the default set of variants that have been tested at the start. if( exists( $seen->{ "@$ref" } ) ) { delete( $seen->{ "@$ref" } ); next; } } $locale->variant( "@$ref" ); push( @$tree, "$locale" ); } pop( @$variants ); } } $locale->variant( undef ); push( @$tree, "$locale" ); if( ( $ref = $self->locale( locale => $locale ) ) && $ref->{parent} ) { my $tree2 = $self->make_inheritance_tree( $ref->{parent} ) || return( $self->pass_error ); push( @$tree, @$tree2 ); return( $tree ); } } if( $locale->territory ) { $locale->territory( undef ); push( @$tree, "$locale" ); if( ( $ref = $self->locale( locale => $locale ) ) && $ref->{parent} ) { my $tree2 = $self->make_inheritance_tree( $ref->{parent} ) || return( $self->pass_error ); push( @$tree, @$tree2 ); return( $tree ); } } if( $locale->script ) { $locale->script( undef ); push( @$tree, "$locale" ); if( ( $ref = $self->locale( locale => $locale ) ) && $ref->{parent} ) { my $tree2 = $self->make_inheritance_tree( $ref->{parent} ) || return( $self->pass_error ); push( @$tree, @$tree2 ); return( $tree ); } } # Make sure our last resort is not the same as our initial value # For example: fr -> fr if( !scalar( grep( $_ eq $locale, @$tree ) ) ) { push( @$tree, "$locale" ); if( ( $ref = $self->locale( locale => $locale ) ) && $ref->{parent} ) { my $tree2 = $self->make_inheritance_tree( $ref->{parent} ) || return( $self->pass_error ); push( @$tree, @$tree2 ); return( $tree ); } } push( @$tree, 'und' ) unless( $tree->[-1] eq 'und' ); return( $tree ); } sub metazone { return( shift->_fetch_one({ id => 'get_metazone', field => 'metazone', table => 'metazones', has_array => [qw( territories timezones )], }, @_ ) ); } sub metazones { return( shift->_fetch_all({ id => 'metazones', table => 'metazones', by => [], has_array => [qw( territories timezones )], }, @_ ) ); } sub metazone_names { return( shift->_fetch_one({ id => 'get_metazone_names', field => 'metazone', table => 'metazones_names', requires => [qw( locale width )], default => { start => undef }, }, @_ ) ); } sub metazones_names { return( shift->_fetch_all({ id => 'metazones_names', table => 'metazones_names', by => [qw( locale metazone width )], }, @_ ) ); } # # sub normalise { my $self = shift( @_ ); my $orig = shift( @_ ); my $ref; unless( Scalar::Util::blessed( $orig ) && $orig->isa( 'Locale::Unicode' ) ) { my $backup = $orig; $orig = Locale::Unicode->new( "$orig" ); if( !defined( $orig ) ) { if( ( $ref = $self->alias( alias => $backup, type => 'language' ) ) && ref( $ref->{replacement} // '' ) eq 'ARRAY' && scalar( @{$ref->{replacement}} ) ) { my $locale = Locale::Unicode->new( $ref->{replacement}->[0] ) || return( $self->pass_error( Locale::Unicode->error ) ); return( $locale ); } else { return( $self->pass_error( Locale::Unicode->error ) ); } } } # canonical will create a clone # my $locale = $orig->canonical; my $locale = $orig; # # # if( my $privateuse = $locale->privateuse ) { $locale->private( $privateuse ); $locale->language3( 'und' ); } elsif( my $grandfathered = $locale->grandfathered ) { if( ( $ref = $self->alias( alias => $grandfathered, type => 'language' ) ) && ref( $ref->{replacement} // '' ) eq 'ARRAY' && scalar( @{$ref->{replacement}} ) ) { my $tmp = Locale::Unicode->new( $ref->{replacement}->[0] ); $tmp = $tmp->canonical; # Ensure the aias value we received is, itself, normalised. $tmp = $self->normalise( $tmp ) || return( $self->pass_error ); $locale->merge( $tmp ); # Do not overwrite it $locale->private( $grandfathered ) unless( $locale->private ); } } elsif( !$locale->language_id ) { $locale->language3( 'und' ); } elsif( ( $ref = $self->alias( alias => "$locale", type => 'language' ) ) && ref( $ref->{replacement} // '' ) eq 'ARRAY' && scalar( @{$ref->{replacement}} ) ) { my $repl = $ref->{replacement}->[0]; while( $ref = $self->alias( alias => $repl, type => 'language' ) && ref( $ref->{replacement} // '' ) eq 'ARRAY' && scalar( @{$ref->{replacement}} ) ) { $repl = $ref->{replacement}->[0]; } my $tmp = Locale::Unicode->new( $repl ); $locale->base( $tmp->base ); } elsif( ( $ref = $self->alias( alias => $locale->language_extended, type => 'language' ) ) && ref( $ref->{replacement} // '' ) eq 'ARRAY' && scalar( @{$ref->{replacement}} ) ) { my $repl = $ref->{replacement}->[0]; while( $ref = $self->alias( alias => $repl, type => 'language' ) && ref( $ref->{replacement} // '' ) eq 'ARRAY' && scalar( @{$ref->{replacement}} ) ) { $repl = $ref->{replacement}->[0]; } my $tmp = Locale::Unicode->new( $repl ); $locale->language_id( undef ); $locale->extended( undef ); $locale->merge( $tmp ); } # As per the LDML specifications: # "If the field = territory, and the replacement.field has more than one value, then look up the most likely territory for the base language code (and script, if there is one). If that likely territory is in the list of replacements, use it. Otherwise, use the first territory in the list." # if( $locale->territory && ( $ref = $self->alias( alias => $locale->territory, type => 'territory' ) ) && ref( $ref->{replacement} // '' ) eq 'ARRAY' && scalar( @{$ref->{replacement}} ) ) { if( scalar( @{$ref->{replacement}} ) > 1 ) { my $tree = $self->make_inheritance_tree( $locale ) || return( $self->pass_error ); my $likely; foreach my $loc ( @$tree ) { $likely = $self->likely_subtag( locale => $loc ); last if( $likely && $likely->{target} ); } if( defined( $likely ) ) { my $tmp = Locale::Unicode->new( $likely->{target} ) || return( $self->pass_error( Locale::Unicode->error ) ); my $cc = $tmp->territory; if( !$cc ) { die( "It seems the Locale::Unicode::Data is corrupted as I could get a likely subtag for ${locale}, but the target '${tmp}' does not seem to contain a territory, which is impossible." ); } if( scalar( grep( /^${cc}$/i, @{$ref->{replacement}} ) ) ) { $locale->territory( $cc ); } else { $locale->territory( $ref->{replacement}->[0] ); } } else { $locale->territory( $ref->{replacement}->[0] ); } } else { $locale->territory( $ref->{replacement}->[0] ); } } if( $locale->variant ) { my $variants = [map{ lc( $_ ) } @{$locale->variants}]; my $permute; $permute = sub { my( $list, $n ) = @_; return( map( [$_], @$list ) ) if( $n <= 1 ); my @comb; for my $i ( 0 .. $#$list ) { my @rest = @$list; my $val = splice( @rest, $i, 1 ); push( @comb, [$val, @$_] ) for( $permute->( \@rest, $n - 1 ) ); } return( @comb ); }; my $seen = {}; my $found = 0; local $" = '-'; my $len = scalar( @$variants ); VARIANTS: while( $len > 0 ) { $seen->{ $variants->[0] }++ if( scalar( @$variants ) ); my @variations = $permute->( $variants, $len ); foreach my $combo ( @variations ) { if( ( $ref = $self->alias( alias => "und-@$combo", type => 'language' ) ) && ref( $ref->{replacement} ) eq 'ARRAY' && scalar( @{$ref->{replacement}} ) ) { MATCH: for( my $i = 0; $i < scalar( @$combo ); $i++ ) { for( my $j = 0; $j < scalar( @$variants ); $j++ ) { if( $combo->[$i] eq $variants->[$j] ) { splice( @$variants, $j, 1 ); next MATCH; } } } # Set the new updated variants if( scalar( @$variants ) ) { $locale->variant( "@$variants" ); } else { $locale->variant( undef ); } my $tmp = Locale::Unicode->new( $ref->{replacement}->[0] ); # language ID 'und' is just a dummy one used. However, if it is anything else, we need to keep it. $tmp->language_id( undef ) if( $tmp->language_id eq 'und' ); $locale->merge( $tmp ); $locale->variant( join( '-', sort( @{$locale->variants} ) ) ); $found++; last VARIANTS; } } # pop( @$variants ); $len--; } unless( $found ) { foreach my $variant ( @{$locale->variants} ) { next if( exists( $seen->{ $variant } ) ); if( ( $ref = $self->alias( alias => 'und-' . $variant, type => 'language' ) ) && ref( $ref->{replacement} ) eq 'ARRAY' && scalar( @{$ref->{replacement}} ) ) { my $tmp = Locale::Unicode->new( $ref->{replacement}->[0] ); $tmp->language_id( undef ); $locale->merge( $tmp ); $found++; last; } } } unless( $found ) { foreach my $variant ( @{$locale->variants} ) { if( ( $ref = $self->alias( alias => $variant, type => 'variant' ) ) && ref( $ref->{replacement} ) eq 'ARRAY' && scalar( @{$ref->{replacement}} ) ) { $locale->variant( $ref->{replacement}->[0] ); $found++; last; } } } } my $script; if( ( $script = $locale->script ) && ( $ref = $self->alias( alias => $script, type => 'script' ) ) && ref( $ref->{replacement} ) eq 'ARRAY' && scalar( @{$ref->{replacement}} ) ) { $locale->script( $ref->{replacement}->[0] ); } return( $locale ); } { no warnings 'once'; *normalize = \&normalise; } sub number_format_l10n { return( shift->_fetch_one({ id => 'get_number_format_l10n', field => 'format_id', table => 'number_formats_l10n', requires => [qw( locale number_system number_type format_length format_type alt count )], default => { alt => undef, count => undef }, }, @_ ) ); } sub number_formats_l10n { return( shift->_fetch_all({ id => 'number_formats_l10n', table => 'number_formats_l10n', by => [qw( locale number_system number_type format_length format_type alt count )], }, @_ ) ); } sub number_symbol_l10n { return( shift->_fetch_one({ id => 'getnumber_symbol_l10n', field => 'property', table => 'number_symbols_l10n', requires => [qw( locale number_system alt )], default => { alt => undef }, }, @_ ) ); } sub number_symbols_l10n { return( shift->_fetch_all({ id => 'number_symbols_l10n', table => 'number_symbols_l10n', by => [qw( locale number_system alt )], }, @_ ) ); } sub number_system { return( shift->_fetch_one({ id => 'get_number_system', field => 'number_system', table => 'number_systems', has_array => [qw( digits )], }, @_ ) ); } sub number_systems { return( shift->_fetch_all({ id => 'number_systems', table => 'number_systems', has_array => [qw( digits )], }, @_ ) ); } sub number_system_l10n { return( shift->_fetch_one({ id => 'getnumber_system_l10n', field => 'number_system', table => 'number_systems_l10n', requires => [qw( locale alt )], default => { alt => undef }, }, @_ ) ); } sub number_systems_l10n { return( shift->_fetch_all({ id => 'number_systems_l10n', table => 'number_systems_l10n', by => [qw( locale number_system alt )], }, @_ ) ); } sub pass_error { my $self = shift( @_ ); my $pack = ref( $self ) || $self; my $opts = {}; my( $err, $class, $code ); no strict 'refs'; if( scalar( @_ ) ) { # Either an hash defining a new error and this will be passed along to error(); or # an hash with a single property: { class => 'Some::ExceptionClass' } if( scalar( @_ ) == 1 && ref( $_[0] ) eq 'HASH' ) { $opts = $_[0]; } else { if( scalar( @_ ) > 1 && ref( $_[-1] ) eq 'HASH' ) { $opts = pop( @_ ); } $err = $_[0]; } } $err = $opts->{error} if( !defined( $err ) && CORE::exists( $opts->{error} ) && defined( $opts->{error} ) && CORE::length( $opts->{error} ) ); # We set $class only if the hash provided is a one-element hash and not an error-defining hash $class = $opts->{class} if( CORE::exists( $opts->{class} ) && defined( $opts->{class} ) && CORE::length( $opts->{class} ) ); $code = $opts->{code} if( CORE::exists( $opts->{code} ) && defined( $opts->{code} ) && CORE::length( $opts->{code} ) ); # called with no argument, most likely from the same class to pass on an error # set up earlier by another method; or # with an hash containing just one argument class => 'Some::ExceptionClass' if( !defined( $err ) && ( !scalar( @_ ) || defined( $class ) ) ) { # $error is a previous erro robject my $error = ref( $self ) ? $self->{error} : length( ${ $pack . '::ERROR' } ) ? ${ $pack . '::ERROR' } : undef; if( !defined( $error ) ) { warn( "No error object provided and no previous error set either! It seems the previous method call returned a simple undef" ); } else { $err = ( defined( $class ) ? bless( $error => $class ) : $error ); $err->code( $code ) if( defined( $code ) ); } } elsif( defined( $err ) && Scalar::Util::blessed( $err ) && ( scalar( @_ ) == 1 || ( scalar( @_ ) == 2 && defined( $class ) ) ) ) { $self->{error} = ${ $pack . '::ERROR' } = ( defined( $class ) ? bless( $err => $class ) : $err ); $self->{error}->code( $code ) if( defined( $code ) && $self->{error}->can( 'code' ) ); if( $self->{fatal} || ( defined( ${"${class}\::FATAL_EXCEPTIONS"} ) && ${"${class}\::FATAL_EXCEPTIONS"} ) ) { die( $self->{error} ); } } # If the error provided is not an object, we call error to create one else { return( $self->error( @_ ) ); } if( Want::want( 'OBJECT' ) ) { rreturn( Locale::Unicode::Data::NullObject->new ); } return; } sub person_name_default { return( shift->_fetch_one({ id => 'get_person_name_default', field => 'locale', table => 'person_name_defaults', }, @_ ) ); } sub person_name_defaults { return( shift->_fetch_all({ id => 'person_name_defaults', table => 'person_name_defaults', }, @_ ) ); } # NOTE: plural rules for 222 locales based on the Unicode CDR rules set out in supplemental/plurals.xml # This is for the method plural_count() my $plural_rules = { # 1: other # bm bo dz hnj id ig ii in ja jbo jv jw kde kea km ko lkt lo ms my nqo osa root sah ses sg su th to tpi vi wo yo yue zh bm => { other => sub { 1 } }, # The other locales in this group are aliased # 2: one, other # am as bn doi fa gu hi kn pcm zu am => { one => sub { $_[0] == 0 || $_[0] == 1 }, other => sub { 1 }, }, # The other locales in this group are aliased # ff hy kab ff => { one => sub { $_[0] == 0 || $_[0] == 1 }, other => sub { 1 }, }, # The other locales in this group are aliased # ast de en et fi fy gl ia io ji lij nl sc sv sw ur yi ast => { one => sub { $_[0] == 1 && int( $_[0] ) == $_[0] }, other => sub { 1 }, }, # The other locales in this group are aliased # si (Sinhala): si => { one => sub { $_[0] == 0 || $_[0] == 1 || # For decimals where the integer part is 0 ( int( $_[0] ) == 0 && $_[0] != 0 ) }, other => sub { 1 }, }, # ak bho csw guw ln mg nso pa ti wa ak => { one => sub { $_[0] == 0 || $_[0] == 1 }, other => sub { 1 }, }, # The other locales in this group are aliased # tzm tzm => { one => sub { $_[0] == 0 || $_[0] == 1 || ( $_[0] >= 11 && $_[0] <= 99 && int( $_[0] ) == $_[0] ) }, other => sub { 1 }, }, # af an asa az bal bem bez bg brx ce cgg chr ckb dv ee el eo eu fo fur gsw ha haw hu jgo jmc ka kaj kcg kk kkj kl ks ksb ku ky lb lg mas mgo ml mn mr nah nb nd ne nn nnh no nr ny nyn om or os pap ps rm rof rwk saq sd sdh seh sn so sq ss ssy st syr ta te teo tig tk tn tr ts ug uz ve vo vun wae xh xog af => { one => sub { $_[0] == 1 && int( $_[0] ) == $_[0] }, other => sub { 1 }, }, # The other locales in this group are aliased # da da => { one => sub { $_[0] == 1 || ( int( $_[0] ) != $_[0] && int( $_[0] ) == 0 ) }, other => sub { 1 }, }, # is: Icelandic is => { one => sub { int( $_[0] ) == $_[0] && ( ( $_[0] % 10 == 1 && $_[0] % 100 != 11 ) || ( int( $_[0] * 10 ) % 10 == 1 && int( $_[0] * 100 ) % 100 != 11 ) ) || # Handling decimals ( int( $_[0] ) != $_[0] && $_[0] < 1.1 ) }, other => sub { 1 }, }, # mk: Macedonian mk => { one => sub { int( $_[0] ) == $_[0] && ( ( $_[0] % 10 == 1 && $_[0] % 100 != 11 ) || ( int( $_[0] * 10 ) % 10 == 1 && int( $_[0] * 100 ) % 100 != 11 ) ) || # Handling decimals ( int( $_[0] ) != $_[0] && $_[0] < 1.1 ) }, other => sub { 1 }, }, # ceb fil tl ceb => { one => sub { int( $_[0] ) == $_[0] && ( ( $_[0] == 1 || $_[0] == 2 || $_[0] == 3 ) || ( $_[0] % 10 != 4 && $_[0] % 10 != 6 && $_[0] % 10 != 9 ) ) || ( int( $_[0] ) != $_[0] && int( $_[0] * 10 ) % 10 != 4 && int( $_[0] * 10 ) % 10 != 6 && int( $_[0] * 10 ) % 10 != 9 ) }, other => sub { 1 }, }, # The other locales in this group are aliased # 3: zero, one, other # lv (Latvian) prg lv => { zero => sub { # Check for very small numbers, including 0 and close to zero # Slightly larger threshold to catch 0.01 and 0.001 abs( $_[0] ) < 0.011 || # Include integers ( int( $_[0] ) == $_[0] && ( $_[0] % 10 == 0 || ( $_[0] % 100 >= 11 && $_[0] % 100 <= 19 ) ) ) }, one => sub { ( $_[0] % 10 == 1 && $_[0] % 100 != 11 ) || # Handle decimals for 'one', excluding numbers very close to zero ( int( $_[0] ) != $_[0] && # Exclude 0.01 explicitly $_[0] > 0.01 && $_[0] < 1.1 ) }, other => sub { 1 }, }, # The other locales in this group are aliased # lag lag => { zero => sub { $_[0] == 0 }, one => sub { $_[0] == 1 || ( int( $_[0] ) == 0 && int( $_[0] ) != $_[0] ) }, other => sub { 1 }, }, # blo blo => { zero => sub { $_[0] == 0 }, one => sub { $_[0] == 1 }, other => sub { 1 }, }, # ksh ksh => { zero => sub { $_[0] == 0 }, one => sub { $_[0] == 1 }, other => sub { 1 }, }, # 3: one, two, other # he iw he => { one => sub { ( $_[0] == 1 && int( $_[0] ) == $_[0] ) || ( int( $_[0] ) != $_[0] && $_[0] > 0 && # Include all non-integers between 0 and 2 for 'one' $_[0] < 2 ) }, two => sub { $_[0] == 2 && int( $_[0] ) == $_[0] }, other => sub { 1 }, }, # The other locales in this group are aliased # iu naq sat se sma smi smj smn sms iu => { one => sub { $_[0] == 1 && int( $_[0] ) == $_[0] }, two => sub { $_[0] == 2 && int( $_[0] ) == $_[0] }, other => sub { 1 }, }, # The other locales in this group are aliased # 3: one, few, other # shi shi => { one => sub { $_[0] == 0 || $_[0] == 1 }, few => sub { $_[0] >= 2 && $_[0] <= 10 && int( $_[0] ) == $_[0] }, other => sub { 1 }, }, # mo ro mo => { one => sub { $_[0] == 1 && int( $_[0] ) == $_[0] }, few => sub { int( $_[0] ) != $_[0] || $_[0] == 0 || ( $_[0] % 100 >= 1 && $_[0] % 100 <= 19 && $_[0] != 1 ) }, other => sub { 1 }, }, # The other locales in this group are aliased # bs (Bosnian) hr sh sr bs => { one => sub { ( int( $_[0] ) == $_[0] && ( ( $_[0] % 10 == 1 && $_[0] % 100 != 11 ) || ( int( $_[0] * 10 ) % 10 == 1 && int( $_[0] * 100 ) % 100 != 11 ) ) ) || # Handle decimals for 'one' ( int( $_[0] ) != $_[0] && $_[0] < 1.1 && $_[0] > 0 && # Exclude numbers like 0.2 from being 'one' $_[0] < 0.2 ) }, few => sub { ( int( $_[0] ) == $_[0] && ( ( $_[0] % 10 >= 2 && $_[0] % 10 <= 4 && $_[0] % 100 < 10 ) || ( $_[0] % 10 >= 2 && $_[0] % 10 <= 4 && $_[0] % 100 >= 20 ) || ( int( $_[0] * 10 ) % 10 >= 2 && int( $_[0] * 10 ) % 10 <= 4 && int( $_[0] * 100 ) % 100 < 10 ) || ( int( $_[0] * 10 ) % 10 >= 2 && int( $_[0] * 10 ) % 10 <= 4 && int( $_[0] * 100 ) % 100 >= 20 ) ) ) || # Handle decimals for 'few' including numbers like 0.2 but not 1.1 ( int( $_[0] ) != $_[0] && ( $_[0] >= 0.2 && $_[0] < 1.2 && # Exclude 1.1 specifically $_[0] != 1.1 ) ) }, many => sub { int( $_[0] ) == $_[0] && ( ( $_[0] % 10 == 0 || ( $_[0] % 10 >= 5 && $_[0] % 10 <= 9 ) || ( $_[0] % 100 >= 11 && $_[0] % 100 <= 14 ) ) || ( int( $_[0] * 10 ) % 10 == 0 || ( int( $_[0] * 10 ) % 10 >= 5 && int( $_[0] * 10 ) % 10 <= 9 ) || ( int( $_[0] * 100 ) % 100 >= 11 && int( $_[0] * 100 ) % 100 <= 14 ) ) ) && # Exclude specific cases that should be 'other' !( $_[0] == 11 || $_[0] == 5 ) && # Exclude decimals that should be 'few' !( $_[0] >= 1.1 && $_[0] < 1.5 ) }, other => sub { 1 }, }, # The other locales in this group are aliased # 3: one, many, other # fr fr => { one => sub { $_[0] == 0 || $_[0] == 1 }, many => sub { ( int( $_[0] ) != $_[0] && ( # Check if there's a fractional part but exclude exact half-integers like 1.5 int( $_[0] * 1000000 ) != int( $_[0] ) * 1000000 && # Explicitly exclude numbers like 1.5 but allow numbers like 1000000.5 !($_[0] - int( $_[0]) == 0.5 && int( $_[0] ) % 1000000 != 0) ) ) || ( int( $_[0] ) != 0 && ( $_[0] % 1000000 == 0 || # Handle cases like 1000000.5 where the integer part is divisible by 1,000,000 (int( $_[0] ) % 1000000 == 0 && $_[0] != int( $_[0] )) ) && int( $_[0] ) == $_[0] && $_[0] > 1 ) }, other => sub { 1 }, }, # pt pt => { one => sub { $_[0] == 0 || $_[0] == 1 }, many => sub { int( $_[0] ) != $_[0] || ( int( $_[0] ) != 0 && $_[0] % 1000000 == 0 && int( $_[0] ) == $_[0] ) }, other => sub { 1 }, }, # ca it lld pt_PT scn vec ca => { one => sub { $_[0] == 1 && int( $_[0] ) == $_[0] }, many => sub { int( $_[0] ) != $_[0] || ( int( $_[0] ) != 0 && $_[0] % 1000000 == 0 && int( $_[0] ) == $_[0] ) }, other => sub { 1 }, }, # The other locales in this group are aliased # es es => { one => sub { $_[0] == 1 && int( $_[0] ) == $_[0] }, many => sub { int( $_[0]) != $_[0] || ( int( $_[0] ) != 0 && $_[0] % 1000000 == 0 && int( $_[0] ) == $_[0] ) }, other => sub { 1 }, }, # 4: one, two, few, other # gd gd => { one => sub { $_[0] == 1 || $_[0] == 11 }, two => sub { $_[0] == 2 || $_[0] == 12 }, few => sub { $_[0] >= 3 && ( $_[0] <= 10 || $_[0] >= 13 ) && $_[0] <= 19 }, other => sub { 1 }, }, # sl sl => { one => sub { int( $_[0]) == $_[0] && $_[0] % 100 == 1 }, two => sub { int( $_[0]) == $_[0] && $_[0] % 100 == 2 }, few => sub { int( $_[0] ) == $_[0] && ( $_[0] % 100 == 3 || $_[0] % 100 == 4 ) || int( $_[0] ) != $_[0] }, other => sub { 1 }, }, # dsb (Lower Sorbian) hsb dsb => { one => sub { ( int( $_[0] ) == $_[0] && ( ( $_[0] % 100 == 1 ) || ( int( $_[0] * 10 ) % 100 == 1 ) ) ) || # Handle decimals for 'one' ( int( $_[0] ) != $_[0] && $_[0] > 0 && $_[0] < 1.1 ) }, two => sub { int( $_[0] ) == $_[0] && ( ( $_[0] % 100 == 2 ) || ( int( $_[0] * 10 ) % 100 == 2 ) ) }, few => sub { int( $_[0] ) == $_[0] && ( ( $_[0] % 100 >= 3 && $_[0] % 100 <= 4 ) || ( int( $_[0] * 10 ) % 100 >= 3 && int( $_[0] * 10 ) % 100 <= 4 ) ) }, other => sub { 1 }, }, # The other locales in this group are aliased # 4: one, few, many, other # cs sk cs => { one => sub { $_[0] == 1 && int( $_[0] ) == $_[0] }, few => sub { $_[0] >= 2 && $_[0] <= 4 && int( $_[0] ) == $_[0] }, many => sub { int( $_[0] ) != $_[0] }, other => sub { 1 }, }, # The other locales in this group are aliased # pl (Polish) pl => { one => sub { $_[0] == 1 && int( $_[0] ) == $_[0] }, few => sub { int( $_[0] ) == $_[0] && $_[0] % 10 >= 2 && $_[0] % 10 <= 4 && ( $_[0] % 100 < 10 || $_[0] % 100 >= 20 ) }, many => sub { int( $_[0] ) == $_[0] && ( $_[0] % 10 == 0 || ( $_[0] % 10 >= 5 && $_[0] % 10 <= 9 ) || ( $_[0] % 100 >= 11 && $_[0] % 100 <= 14 ) ) || int( $_[0] ) != $_[0] }, other => sub { 1 }, }, # be (Belarusian) be => { one => sub { int( $_[0] ) == $_[0] && $_[0] % 10 == 1 && $_[0] % 100 != 11 }, few => sub { int( $_[0] ) == $_[0] && $_[0] % 10 >= 2 && $_[0] % 10 <= 4 && ( $_[0] % 100 < 10 || $_[0] % 100 >= 20 ) }, many => sub { int( $_[0] ) == $_[0] && ( ( $_[0] % 10 == 0 || $_[0] % 10 >= 5 ) || ( $_[0] % 100 >= 11 && $_[0] % 100 <= 14 ) ) }, other => sub { int( $_[0] ) != $_[0] }, }, # lt (Lithuanian) lt => { one => sub { int( $_[0] ) == $_[0] && $_[0] % 10 == 1 && !( $_[0] % 100 >= 11 && $_[0] % 100 <= 19 ) }, few => sub { int( $_[0] ) == $_[0] && $_[0] % 10 >= 2 && $_[0] % 10 <= 9 && ( $_[0] % 100 < 10 || $_[0] % 100 >= 20 ) }, many => sub { int( $_[0] ) != $_[0] }, other => sub { int( $_[0] ) == $_[0] && ( $_[0] % 100 >= 11 && ( $_[0] % 100 <= 19 || $_[0] % 10 == 0 ) ) }, }, # ru (Russian) uk (Ukrainian) ru => { one => sub { int( $_[0] ) == $_[0] && $_[0] % 10 == 1 && $_[0] % 100 != 11 }, few => sub { int( $_[0] ) == $_[0] && $_[0] % 10 >= 2 && $_[0] % 10 <= 4 && ( $_[0] % 100 < 10 || $_[0] % 100 >= 20 ) }, many => sub { int( $_[0] ) == $_[0] && ( ( $_[0] % 10 == 0 || $_[0] % 10 >= 5 ) || ( $_[0] % 100 >= 11 && $_[0] % 100 <= 14 ) ) }, other => sub { int( $_[0] ) != $_[0] }, }, # The other locales in this group are aliased # 5: one, two, few, many, other # br br => { one => sub { int( $_[0] ) == $_[0] && $_[0] % 10 == 1 && $_[0] % 100 != 11 && $_[0] % 100 != 71 && $_[0] % 100 != 91 }, two => sub { int( $_[0] ) == $_[0] && $_[0] % 10 == 2 && $_[0] % 100 != 12 && $_[0] % 100 != 72 && $_[0] % 100 != 92 }, few => sub { int( $_[0] ) == $_[0] && ( ( $_[0] % 10 >= 3 && ( $_[0] % 10 <= 4 || $_[0] % 10 == 9 ) ) && ( $_[0] % 100 < 10 || $_[0] % 100 > 19 ) && ( $_[0] % 100 < 70 || $_[0] % 100 > 79 ) && ( $_[0] % 100 < 90 || $_[0] % 100 > 99 ) ) }, many => sub { int( $_[0] ) == $_[0] && $_[0] != 0 && $_[0] % 1000000 == 0 }, other => sub { 1 }, }, # mt mt => { one => sub { $_[0] == 1 && int( $_[0] ) == $_[0] }, two => sub { $_[0] == 2 && int( $_[0] ) == $_[0] }, few => sub { $_[0] == 0 || ( int( $_[0] ) == $_[0] && $_[0] % 100 >= 3 && $_[0] % 100 <= 10 ) }, many => sub { int( $_[0] ) == $_[0] && $_[0] % 100 >= 11 && $_[0] % 100 <= 19 }, other => sub { 1 }, }, # ga ga => { one => sub { $_[0] == 1 && int( $_[0] ) == $_[0] }, two => sub { $_[0] == 2 && int( $_[0] ) == $_[0] }, few => sub { $_[0] >= 3 && $_[0] <= 6 && int( $_[0] ) == $_[0] }, many => sub { $_[0] >= 7 && $_[0] <= 10 && int( $_[0] ) == $_[0] }, other => sub { 1 }, }, # gv gv => { one => sub { int( $_[0] ) == $_[0] && $_[0] % 10 == 1 }, two => sub { int( $_[0] ) == $_[0] && $_[0] % 10 == 2 }, few => sub { int( $_[0] ) == $_[0] && ( $_[0] % 100 == 0 || $_[0] % 100 == 20 || $_[0] % 100 == 40 || $_[0] % 100 == 60 || $_[0] % 100 == 80 ) }, many => sub { int( $_[0] ) != $_[0] }, other => sub { 1 }, }, # 6: zero, one, two, few, many, other # kw (Cornish) kw => { zero => sub { $_[0] == 0 }, one => sub { $_[0] == 1 }, two => sub { int( $_[0] ) == $_[0] && ( # Directly include 2 $_[0] == 2 || # Existing conditions for other cases ( ( $_[0] % 100 == 22 || $_[0] % 100 == 42 || $_[0] % 100 == 62 || $_[0] % 100 == 82 ) || ( $_[0] % 1000 == 0 && ( $_[0] % 100000 >= 1000 && $_[0] % 100000 <= 20000 ) ) || ( $_[0] % 100000 == 40000 || $_[0] % 100000 == 60000 || $_[0] % 100000 == 80000 ) || ( $_[0] % 1000000 == 100000 && $_[0] != 0 ) ) ) }, few => sub { int( $_[0] ) == $_[0] && ( $_[0] % 100 == 3 || $_[0] % 100 == 23 || $_[0] % 100 == 43 || $_[0] % 100 == 63 || $_[0] % 100 == 83 ) }, many => sub { int( $_[0] ) == $_[0] && $_[0] != 1 && ( $_[0] % 100 == 1 || $_[0] % 100 == 21 || $_[0] % 100 == 41 || $_[0] % 100 == 61 || $_[0] % 100 == 81 ) }, other => sub { 1 }, }, # ar ars ar => { zero => sub { $_[0] == 0 }, one => sub { $_[0] == 1 }, two => sub { $_[0] == 2 }, few => sub { int( $_[0] ) == $_[0] && $_[0] % 100 >= 3 && $_[0] % 100 <= 10 }, many => sub { int( $_[0] ) == $_[0] && $_[0] % 100 >= 11 && $_[0] % 100 <= 99 }, other => sub { 1 }, }, # The other locales in this group are aliased # cy cy => { zero => sub { $_[0] == 0 }, one => sub { $_[0] == 1 }, two => sub { $_[0] == 2 }, few => sub { $_[0] == 3 }, many => sub { $_[0] == 6 }, other => sub { 1 }, }, }; # Aliasing my $aliases = { # 1: other bm => [qw( bo dz hnj id ig ii in ja jbo jv jw kde kea km ko lkt lo ms my nqo osa root sah ses sg su th to tpi vi wo yo yue zh )], # 2: one, other am => [qw( as bn doi fa gu hi kn pcm zu )], ff => [qw( hy kab )], ast => [qw( de en et fi fy gl ia io ji lij nl sc sv sw ur yi )], ak => [qw( bho csw guw ln mg nso pa ti wa )], af => [qw( an asa az bal bem bez bg brx ce cgg chr ckb dv ee el eo eu fo fur gsw ha haw hu jgo jmc ka kaj kcg kk kkj kl ks ksb ku ky lb lg mas mgo ml mn mr nah nb nd ne nn nnh no nr ny nyn om or os pap ps rm rof rwk saq sd sdh seh sn so sq ss ssy st syr ta te teo tig tk tn tr ts ug uz ve vo vun wae xh xog )], ceb => [qw( fil tl )], # 3: zero,one,other lv => [qw( prg )], # 3: one,two,other he => [qw( iw )], iu => [qw( naq sat se sma smi smj smn sms )], # 3: one,few,other mo => [qw( ro )], bs => [qw( hr sh sr )], # 3: one,many,other ca => [qw( it lld pt-PT scn vec )], # 4: one,two,few,other dsb => [qw( hsb )], # 4: one,few,many,other cs => [qw( sk )], ru => [qw( uk )], # 5: one,two,few,many,other # No aliases in this group # 6: zero,one,two,few,many,other ar => [qw( ars )], }; foreach my $locale ( keys( %$aliases ) ) { $plural_rules->{ $_ } = $plural_rules->{ $locale } for( @{$aliases->{ $locale }} ); } # https://unicode.org/reports/tr35/tr35-numbers.html#Language_Plural_Rules # https://cldr.unicode.org/index/cldr-spec/plural-rules # https://unicode.org/reports/tr35/tr35-dates.html#Contents sub plural_count { my $self = shift( @_ ); my $number = shift( @_ ); my $locale = shift( @_ ); if( !length( $number // '' ) ) { return( $self->error( "No number was provided to get its plural count." ) ); } elsif( !length( $locale ) ) { return( $self->error( "No locale was provided to get its plural count." ) ); } $locale = $self->_locale_object( $locale ) || return( $self->pass_error ); my $rules; my $tree = $self->make_inheritance_tree( $locale->base ) || return( $self->pass_error ); foreach my $loc ( @$tree ) { if( exists( $plural_rules->{ $loc } ) ) { $rules = $plural_rules->{ $loc }; last; } } # I could also write it as $rules //= { one => sub { $_[0] == 1 }, other => sub { 1 } }; # but I would lose point for readability if( !defined( $rules ) ) { $rules = { one => sub { $_[0] == 1 }, other => sub { 1 } }; } foreach my $category ( qw( zero one two few many other ) ) { if( exists( $rules->{ $category } ) && $rules->{ $category }->( $number ) ) { return( $category ); } } # It should never reach here return( 'other' ); } sub plural_range { return( shift->_fetch_one({ id => 'get_plural_range', field => 'result', table => 'plural_ranges', requires => [qw( locale start stop )], default => { alt => undef }, }, @_ ) ); } sub plural_ranges { return( shift->_fetch_all({ id => 'plural_ranges', table => 'plural_ranges', by => [qw( locale aliases start stop result )], }, @_ ) ); } sub plural_rule { return( shift->_fetch_one({ id => 'get_plural_rule', field => 'rule', table => 'plural_rules', requires => [qw( locale count )], }, @_ ) ); } sub plural_rules { return( shift->_fetch_all({ id => 'plural_rules', table => 'plural_rules', by => [qw( locale aliases count rule )], }, @_ ) ); } sub rbnf { return( shift->_fetch_one({ id => 'get_rbnf', field => 'rule_id', table => 'rbnf', requires => [qw( locale ruleset )], }, @_ ) ); } sub rbnfs { return( shift->_fetch_all({ id => 'rbnf', table => 'rbnf', by => [qw( locale grouping ruleset )], }, @_ ) ); } sub reference { return( shift->_fetch_one({ id => 'get_ref', field => 'code', table => 'refs', }, @_ ) ); } sub references { return( shift->_fetch_all({ id => 'refs', table => 'refs', }, @_ ) ); } sub script { return( shift->_fetch_one({ id => 'get_script', field => 'script', table => 'scripts', }, @_ ) ); } sub scripts { return( shift->_fetch_all({ id => 'scripts', table => 'scripts', by => [qw( rtl origin_country likely_language )], has_status => 1, }, @_ ) ); } sub script_l10n { return( shift->_fetch_one({ id => 'get_script_l10n', field => 'script', table => 'scripts_l10n', requires => [qw( locale alt )], default => { alt => undef }, }, @_ ) ); } sub scripts_l10n { return( shift->_fetch_all({ id => 'scripts_l10n', table => 'scripts_l10n', by => [qw( locale alt )], }, @_ ) ); } sub split_interval { my $self = shift( @_ ); my $opts = $self->_get_args_as_hash( @_ ); my $greatest_diff = $opts->{greatest_diff} || return( $self->error( "No 'greatest_diff' argument value was provided." ) ); my $pat = $opts->{pattern} || return( $self->error( "No pattern was provided." ) ); # {0} – {1} if( $pat =~ /^(?\{\d\})(?[^\{]+)(?\{\d\})$/ ) { return( [ $+{p1}, $+{sep}, $+{p2} ] ); } # First, remove the quoted literals from our string so they do not interfer my $literals = {}; my $spaces = []; if( index( $pat, "'" ) != -1 ) { my $n = 0; $pat =~ s{ (?{ $1 } ) ) { $literals->{ $1 } = ++$n; } $literals->{ $1 } . '__'; }gexs; } $pat =~ s{ ([[:blank:]\h]+) } { push( @$spaces, $1 ); ' '; }gexs; my $len = length( $pat ); my $matches = {}; my( $part1, $part2, $sep ); my $equivalent = { 'L' => 'M', 'LL' => 'MM', 'LLL' => 'MMM', 'LLLL' => 'MMMM', 'LLLLL' => 'MMMMM', 'LLLLLL' => 'MMMMMM', 'M' => 'L', 'MM' => 'LL', 'MMM' => 'LLL', 'MMMM' => 'LLLL', 'MMMM' => 'LLLLL', 'MMMMM' => 'LLLLLL', }; OUTER: for( my $i = 0; $i < $len; $i++ ) { INNER: for( my $j = 1; $j < ( $len - $i ); $j++ ) { my $check = substr( $pat, $i, $j ); next OUTER if( $check =~ /^[^a-zA-Z]$/ ); my $pos = index( $pat, $check, $i + length( $check ) ); if( exists( $equivalent->{ $check } ) && $pos == -1 ) { $pos = index( $pat, $equivalent->{ $check }, $i + length( $equivalent->{ $check } ) ); $check = $equivalent->{ $check } if( $pos != -1 ); } if( $pos != -1 ) { $matches->{ substr( $pat, $pos, length( $check ) ) } = [$i, $pos]; } } } if( !scalar( keys( %$matches ) ) ) { warn( "Failed to find the repeating field in pattern '${pat}'" ) if( warnings::enabled() ); return( [] ); } my @bests = sort{ length( $b ) <=> length( $a ) } keys( %$matches ); my $max_len = length( $bests[0] ); my $best; if( scalar( @bests ) > 1 && length( $bests[1] ) == $max_len ) { my $found; foreach my $this ( @bests ) { if( index( $this, $greatest_diff ) != -1 ) { $found = $this; last; } } if( !defined( $found ) ) { return( $self->error( "Found ", scalar( @bests ), " candidates, but none had the greatest difference field ${greatest_diff}" ) ); } else { $best = $found; } } else { $best = $bests[0]; } my( $start1, $start2 ) = @{$matches->{ $best }}; $part1 = substr( $pat, 0, ( $start1 + length( $best ) ) ); $part2 = substr( $pat, $start2 ); $sep = substr( $pat, $start1 + length( $best ), ( $start2 - ( $start1 + length( $best ) ) ) ); if( scalar( @$spaces ) ) { my $c = 0; for( $part1, $sep, $part2 ) { s/([[:blank:]\h]+)/$spaces->[$c++]/g; } } if( scalar( keys( %$literals ) ) ) { my $vals = { map{ $literals->{ $_ } => $_ } keys( %$literals ) }; for( $part1, $part2, $sep ) { s/(\d+)__/$vals->{ $1 }/g; } } return( [ $part1, $sep, $part2, $best ] ); } sub subdivision { return( shift->_fetch_one({ id => 'get_subdivision', field => 'subdivision', table => 'subdivisions', }, @_ ) ); } sub subdivisions { return( shift->_fetch_all({ id => 'subdivisions', table => 'subdivisions', by => [qw( territory parent is_top_level )], has_status => 1, }, @_ ) ); } sub subdivision_l10n { return( shift->_fetch_one({ id => 'get_subdivision_l10n', field => 'subdivision', table => 'subdivisions_l10n', requires => [qw( locale )], }, @_ ) ); } sub subdivisions_l10n { return( shift->_fetch_all({ id => 'subdivisions_l10n', table => 'subdivisions_l10n', by => [qw( locale )], }, @_ ) ); } sub territory { return( shift->_fetch_one({ id => 'get_territory', field => 'territory', table => 'territories', has_array => [qw( languages contains calendars weekend )], }, @_ ) ); } sub territories { return( shift->_fetch_all({ id => 'territories', table => 'territories', by => [qw( parent alt )], has_status => 1, has_array => [qw( languages contains calendars weekend )], }, @_ ) ); } sub territory_l10n { return( shift->_fetch_one({ id => 'get_territory_l10n', field => 'territory', table => 'territories_l10n', requires => [qw( locale alt )], default => { alt => undef }, }, @_ ) ); } sub territories_l10n { return( shift->_fetch_all({ id => 'territories_l10n', table => 'territories_l10n', by => [qw( locale alt )], }, @_ ) ); } sub time_format { return( shift->_fetch_one({ id => 'get_time_format', field => 'region', table => 'time_formats', has_array => [qw( time_allowed )], }, @_ ) ); } sub time_formats { return( shift->_fetch_all({ id => 'time_formats', table => 'time_formats', by => [qw( region territory locale )], has_array => [qw( time_allowed )], }, @_ ) ); } sub time_relative_l10n { return( shift->_fetch_one({ id => 'get_time_relative_l10n', field => 'relative', table => 'time_relative_l10n', requires => [qw( locale field_type field_length count )], default => { count => 'one' }, }, @_ ) ); } sub time_relatives_l10n { return( shift->_fetch_all({ id => 'time_relative_l10n', table => 'time_relative_l10n', by => [qw( locale field_type field_length count )], }, @_ ) ); } sub timezone { return( shift->_fetch_one({ id => 'get_timezone', field => 'timezone', table => 'timezones', has_array => [qw( alias )], }, @_ ) ); } sub timezones { return( shift->_fetch_all({ id => 'timezones', table => 'timezones', by => [qw( territory region tzid tz_bcpid metazone is_golden is_primary is_canonical )], has_array => [qw( alias )], }, @_ ) ); } sub timezone_canonical { my $self = shift( @_ ); my $tz = shift( @_ ) || return( $self->error( "No timezone was provided to get its canonical version." ) ); my $dbh = $self->_dbh || return( $self->pass_error ); my $sth_id = 'sth_get_timezone'; local $@; my $sth; unless( $sth = $self->_get_cached_statement( $sth_id ) ) { # try-catch $sth = eval { $dbh->prepare( "SELECT * FROM timezones WHERE timezone = ?" ) } || return( $self->error( "Unable to prepare SQL query with statement ID ${sth_id} to retrieve the given timezone information: ", ( $@ || $dbh->errstr ) ) ); $self->_set_cached_statement( $sth_id => $sth ); } # try-catch eval { $sth->execute( $tz ); } || return( $self->error( "Error executing SQL query '$sth->{Statement}' with statement ID ${sth_id} to retrieve the given timezone information:", ( $@ || $sth->errstr ), " with SQL query: ", $sth->{Statement} ) ); my $ref = $sth->fetchrow_hashref; return( $self->error( "No timezone '${tz}' exists in the Locale::Unicode::Data database." ) ) if( !$ref ); $self->_decode_utf8( $ref ) if( MISSING_AUTO_UTF8_DECODING ); $self->_decode_sql_arrays( ['alias'], $ref ); if( $ref->{is_canonical} ) { return( $ref->{timezone} ); } elsif( $ref->{alias} && ref( $ref->{alias} ) eq 'ARRAY' && scalar( @{$ref->{alias}} ) ) { $sth_id = 'sth_get_timezone_multi_' . scalar( @{$ref->{alias}} ); unless( $sth = $self->_get_cached_statement( $sth_id ) ) { # try-catch $sth = eval { $dbh->prepare( "SELECT * FROM timezones WHERE " . join( ' OR ', map{ "timezone = ?" } @{$ref->{alias}} ) ) } || return( $self->error( "Unable to prepare SQL query with statement ID ${sth_id} to retrieve one of " . scalar( @{$ref->{alias}} ) . " timezone(s) information: ", ( $@ || $dbh->errstr ) ) ); $self->_set_cached_statement( $sth_id => $sth ); } # try-catch eval { $sth->execute( @{$ref->{alias}} ); } || return( $self->error( "Error executing SQL query '$sth->{Statement}' with statement ID ${sth_id} to retrieve one of " . scalar( @{$ref->{alias}} ) . " timezone(s) information:", ( $@ || $sth->errstr ), " with SQL query: ", $sth->{Statement} ) ); my $all = $sth->fetchall_arrayref({}); foreach my $this ( @$all ) { return( $this->{timezone} ) if( $this->{is_canonical} ); } } return( '' ); } sub timezone_city { my $self = shift( @_ ); my $is_extended = $self->extend_timezones_cities; return( $self->_fetch_one({ id => 'get_timezone_city', field => 'timezone', table => ( $is_extended ? 'timezones_cities_extended' : 'timezones_cities' ), requires => [qw( locale alt )], default => { alt => undef }, }, @_ ) ); } sub timezones_cities { my $self = shift( @_ ); my $is_extended = $self->extend_timezones_cities; return( $self->_fetch_all({ id => 'timezones_cities', table => ( $is_extended ? 'timezones_cities_extended' : 'timezones_cities' ), by => [qw( locale alt )], }, @_ ) ); } sub timezone_formats { return( shift->_fetch_one({ id => 'get_timezone_formats', field => 'type', table => 'timezones_formats', requires => [qw( locale subtype )], default => { subtype => undef }, }, @_ ) ); } sub timezones_formats { return( shift->_fetch_all({ id => 'timezones_formats', table => 'timezones_formats', by => [qw( locale type subtype format_pattern )], }, @_ ) ); } sub timezone_info { return( shift->_fetch_one({ id => 'get_timezone_info', field => 'timezone', table => 'timezones_info', requires => [qw( start )], default => { start => undef }, }, @_ ) ); } sub timezones_info { return( shift->_fetch_all({ id => 'timezones_info', table => 'timezones_info', by => [qw( timezone metazone start until )], }, @_ ) ); } sub timezone_names { return( shift->_fetch_one({ id => 'get_timezone_names', field => 'timezone', table => 'timezones_names', requires => [qw( locale width )], default => { start => undef }, }, @_ ) ); } sub timezones_names { return( shift->_fetch_all({ id => 'timezones_names', table => 'timezones_names', by => [qw( locale timezone width )], }, @_ ) ); } sub unit_alias { return( shift->_fetch_one({ id => 'get_unit_alias', field => 'alias', table => 'unit_aliases', }, @_ ) ); } sub unit_aliases { return( shift->_fetch_all({ id => 'unit_aliases', table => 'unit_aliases', }, @_ ) ); } sub unit_constant { return( shift->_fetch_one({ id => 'get_unit_constant', field => 'constant', table => 'unit_constants', }, @_ ) ); } sub unit_constants { return( shift->_fetch_all({ id => 'unit_constants', table => 'unit_constants', }, @_ ) ); } sub unit_conversion { return( shift->_fetch_one({ id => 'get_unit_conversion', field => 'source', table => 'unit_conversions', has_array => [qw( systems )], }, @_ ) ); } sub unit_conversions { return( shift->_fetch_all({ id => 'unit_conversions', table => 'unit_conversions', by => [qw( base_unit category )], has_array => [qw( systems )], }, @_ ) ); } sub unit_l10n { return( shift->_fetch_one({ id => 'get_unit_l10n', field => 'unit_id', table => 'units_l10n', requires => [qw( locale format_length unit_type count gender gram_case )], default => { count => undef, gender => undef, gram_case => undef }, }, @_ ) ); } sub units_l10n { return( shift->_fetch_all({ id => 'units_l10n', table => 'units_l10n', by => [qw( locale format_length unit_type unit_id pattern_type count gender gram_case )], }, @_ ) ); } sub unit_prefix { return( shift->_fetch_one({ id => 'get_unit_prefix', field => 'unit_id', table => 'unit_prefixes', }, @_ ) ); } sub unit_prefixes { return( shift->_fetch_all({ id => 'unit_prefixes', table => 'unit_prefixes', }, @_ ) ); } sub unit_pref { return( shift->_fetch_one({ id => 'get_unit_pref', field => 'unit_id', table => 'unit_prefs', }, @_ ) ); } sub unit_prefs { return( shift->_fetch_all({ id => 'unit_prefs', table => 'unit_prefs', by => [qw( territory category )], }, @_ ) ); } sub unit_quantity { return( shift->_fetch_one({ id => 'get_unit_quantity', field => 'base_unit', table => 'unit_quantities', }, @_ ) ); } sub unit_quantities { return( shift->_fetch_all({ id => 'unit_quantities', table => 'unit_quantities', by => [qw( quantity )], has_status => 1, }, @_ ) ); } sub variant { return( shift->_fetch_one({ id => 'get_variant', field => 'variant', table => 'variants', }, @_ ) ); } sub variants { return( shift->_fetch_all({ id => 'variants', table => 'variants', has_status => 1, }, @_ ) ); } sub variant_l10n { return( shift->_fetch_one({ id => 'get_variant_l10n', field => 'variant', table => 'variants_l10n', requires => [qw( locale alt )], default => { alt => undef }, }, @_ ) ); } sub variants_l10n { return( shift->_fetch_all({ id => 'variants_l10n', table => 'variants_l10n', by => [qw( locale alt )], }, @_ ) ); } sub week_preference { return( shift->_fetch_one({ id => 'get_week_preference', field => 'locale', table => 'week_preferences', has_array => [qw( ordering )], }, @_ ) ); } sub week_preferences { return( shift->_fetch_all({ id => 'week_preferences', table => 'week_preferences', has_array => [qw( ordering )], }, @_ ) ); } sub _dbh { my $self = shift( @_ ); my $opts = $self->_get_args_as_hash( @_ ); my $file = $opts->{datafile} || $self->datafile || $DB_FILE; my $dbh; if( $DBH && ref( $DBH ) eq 'HASH' && exists( $DBH->{ $file } ) && $DBH->{ $file } && Scalar::Util::blessed( $DBH->{ $file } ) && $DBH->{ $file }->isa( 'DBI::db' ) && $DBH->{ $file }->ping ) { return( $DBH->{ $file } ); } if( !-e( $file ) ) { return( $self->error( "Unicode CLDR SQLite database file ${file} does not exist!" ) ); } elsif( !-f( $file ) ) { return( $self->error( "Unicode CLDR SQLite database file ${file} is not a regular file." ) ); } elsif( -z( $file ) ) { return( $self->error( "Unicode CLDR SQLite database file ${file} is empty!" ) ); } elsif( !-r( $file ) ) { return( $self->error( "Unicode CLDR SQLite database file ${file} is not readable by uid $>" ) ); } elsif( version->parse( $DBD::SQLite::sqlite_version ) < version->parse( '3.6.19' ) ) { return( $self->error( "SQLite driver version 3.6.19 or higher is required. You have version ", $DBD::SQLite::sqlite_version ) ); } if( HAS_CONSTANTS ) { require DBD::SQLite::Constants; } my $params = { ( HAS_CONSTANTS ? ( sqlite_open_flags => DBD::SQLite::Constants::SQLITE_OPEN_READONLY ) : () ), }; $dbh = DBI->connect( "dbi:SQLite:dbname=${file}", '', '', $params ) || return( $self->error( "Unable to make connection to Unicode CLDR SQLite database file ${file}: ", $DBI::errstr ) ); # See: $dbh->do("PRAGMA foreign_keys = ON"); # UTF-8 decoding is done natively from version 1.68 onward if( !MISSING_AUTO_UTF8_DECODING ) { $dbh->{sqlite_string_mode} = DBD::SQLite::Constants::DBD_SQLITE_STRING_MODE_UNICODE_FALLBACK; } return( $DBH->{ $file } = $dbh ); } sub _decode_sql_arrays { my $self = shift( @_ ); die( "\$cldr->_decode_sql_arrays( \$array_ref_of_array_fields, \$data )" ) if( @_ != 2 ); my( $where, $ref ) = @_; if( ref( $where ) ne 'ARRAY' ) { die( "\$cldr->_decode_sql_arrays( \$array_ref_of_array_fields, \$data )" ); } elsif( ref( $ref // '' ) ne 'HASH' && Scalar::Util::reftype( $ref // '' ) ne 'ARRAY' ) { die( "\$cldr->_decode_sql_arrays( \$array_ref_of_array_fields, \$data )" ); } my $j = JSON->new->relaxed; local $@; if( ref( $ref ) eq 'HASH' ) { foreach my $field ( @$where ) { if( exists( $ref->{ $field } ) && defined( $ref->{ $field } ) && length( $ref->{ $field } ) ) { my $decoded = eval { $j->decode( $ref->{ $field } ); }; if( $@ ) { warn( "Warning only: error attempting to decode JSON array in field \"${field}\" for value '", $ref->{ $field }, "': $@" ); $ref->{ $field } = []; } else { $ref->{ $field } = $decoded; } } } } elsif( Scalar::Util::reftype( $ref ) eq 'ARRAY' ) { for( my $i = 0; $i < scalar( @$ref ); $i++ ) { if( ref( $ref->[$i] ) ne 'HASH' ) { warn( "SQL data at offset ${i} is not an HASH reference." ); next; } $self->_decode_sql_arrays( $where, $ref->[$i] ); } } return( $ref ); } sub _decode_utf8 { my $self = shift( @_ ); my $this = shift( @_ ); if( ref( $this ) eq 'HASH' ) { foreach my $k ( keys( %$this ) ) { next if( !defined( $this->{ $k } ) ); if( ref( $this->{ $k } ) eq 'ARRAY' || !ref( $this->{ $k } ) ) { $this->{ $k } = $self->_decode_utf8( $this->{ $k } ); } } } elsif( ref( $this ) eq 'ARRAY' ) { for( my $i = 0; $i < scalar( @$this ); $i++ ) { next if( !defined( $this->[$i] ) ); if( ref( $this->[$i] ) eq 'HASH' || !ref( $this->[$i] ) ) { $this->[$i] = $self->_decode_utf8( $this->[$i] ); } } } elsif( !ref( $this ) ) { my $val = eval { Encode::decode_utf8( $this, Encode::FB_CROAK ); }; if( $@ ) { warn( "Error utf-8 decoding: $@" ) if( warnings::enabled() ); return( $this ); } else { return( $val ); } } return( $this ); } sub _fetch_all { my $self = shift( @_ ); my $def = shift( @_ ) || return( $self->error( "No hash definition provided." ) ); return( $self->error( "Hash definition is not an hash reference." ) ) if( ref( $def ) ne 'HASH' ); my $table = $def->{table} || return( $self->error( "No SQL table name was provided." ) ); my $id = $def->{id} || $table; my $what = $def->{what} || $table; my $order = exists( $def->{order} ) ? $def->{order} : 'rowid'; my $opts = $self->_get_args_as_hash( @_ ); my $status = $def->{has_status} ? $def->{has_status} =~ /[a-zA-Z]/ ? $def->{has_status} : 'status' : undef; my $by = ( exists( $def->{by} ) && ref( $def->{by} ) eq 'ARRAY' ? $def->{by} : [] ); my $order_by_value = []; if( exists( $opts->{order_by_value} ) && defined( $opts->{order_by_value} ) ) { if( ref( $opts->{order_by_value} ) eq 'ARRAY' ) { $order_by_value = $opts->{order_by_value}; } else { $order_by_value = [$opts->{order_by_value}]; } } if( scalar( @$order_by_value ) ) { if( scalar( @$order_by_value ) != 2 ) { die( "Invalid number of parameter for order by field value. You need to provide a field name and an array reference of values." ); } elsif( ref( $order_by_value->[1] ) ne 'ARRAY' ) { die( "Invalid parameters provided for order by field value. The second parameter must be an array reference of value to sort with." ); } elsif( !scalar( @{$order_by_value->[1]} ) ) { die( "The array of value to sort the data for field '", ( $order_by_value->[0] // 'undef' ), "' is empty." ); } my $field = $order_by_value->[0]; my @cases; for( my $i = 0; $i < scalar( @{$order_by_value->[1]} ); $i++ ) { push( @cases, sprintf( "WHEN '%s' THEN %d", $order_by_value->[1]->[$i], $i ) ); } my $case = "CASE ${field} " . join( ' ', @cases ) . ' END'; $order = $case; } # order option to override any default order directive if( exists( $opts->{order} ) ) { my( $field, $datatype ); if( ref( $opts->{order} ) eq 'HASH' ) { my @keys = keys( %{$opts->{order}} ); if( scalar( @keys ) != 1 ) { local $" = ', '; die( "You can only specify one order field to cast. Here, you provided: @keys" ); } ( $field, $datatype ) = ( $keys[0], $opts->{order}->{ $keys[0] } ); } elsif( ref( $opts->{order} ) eq 'ARRAY' ) { if( scalar( @{$opts->{order}} ) != 2 ) { die( "You need to provide a 2-elements array. The first element is the field name and the second element the data type. You provided ", scalar( @{$opts->{order}} ), " element(s)." ); } ( $field, $datatype ) = @{$opts->{order}}; } else { $field = $opts->{order}; } if( defined( $field ) && defined( $datatype ) ) { if( !length( $field // '' ) ) { die( "The order field value provided is empty!" ); } elsif( !length( $datatype // '' ) ) { die( "The order datatype value provided is empty!" ); } elsif( $field !~ /^[a-zA-Z0-9\_]+$/ ) { die( "The order field name provided contains illegal value. It must be an alphanumerical string, with possible '_' character." ); } elsif( $datatype !~ /^[a-zA-Z0-9]+$/ ) { die( "The order field data type contains an illegal value. It must be a string of alpha numeric characters." ); } $order = "CAST(${field} AS \U${datatype}\E)"; } elsif( defined( $field ) ) { die( "The order field value provided is empty!" ) if( !length( $field // '' ) ); if( $field !~ /^[a-zA-Z0-9\_]+$/ ) { die( "The order field name provided contains illegal value. It must be an alphanumerical string, with possible '_' character." ); } } } my $sql_arrays_in = ( exists( $def->{has_array} ) && ref( $def->{has_array} ) eq 'ARRAY' ? $def->{has_array} : [] ); my $sth; my $op_map = { '=' => 'IS', '!=' => 'IS NOT', }; my $by_values = []; my $skeleton = []; my $by_keys = []; if( scalar( @$by ) ) { for( @$by ) { return( $self->error( "Table field provided '$_' contains illegal characters." ) ) if( $_ !~ /^[a-z][a-z0-9]+(?:\_[a-z][a-z0-9]+)*$/ ); next unless( exists( $opts->{ $_ } ) ); if( ref( $opts->{ $_ } // '' ) eq 'ARRAY' ) { my $and_skels = []; for( my $i = 0; $i < scalar( @{$opts->{ $_ }} ); $i++ ) { my $op = '='; my $val = $opts->{ $_ }->[$i]; if( defined( $val ) && $val =~ s/^[[:blank:]\h]*(?\<|\<=|\>|\>=|=|\!=|\~)[[:blank:]\h]*(?.*?)$/$+{val}/ ) { $op = $+{op}; } elsif( defined( $val ) && ref( $val ) eq 'Regexp' ) { $op = '~'; $val =~ s/^\(\?[^\:]+\:(.*?)\)$/$1/; } $op = $op_map->{ $op } if( exists( $op_map->{ $op } ) ); if( $op eq '~' ) { push( @$and_skels, "$_ REGEXP(?)" ); push( @$by_keys, "regexp_${_}" ); } else { push( @$and_skels, "$_ ${op} ?" ); push( @$by_keys, "${op}${_}" ); } push( @$by_values, defined( $val ) ? ( Scalar::Util::blessed( $val ) && overload::Method( $val => '""' ) ) ? "$val" : $val : $val ); } push( @$skeleton, '( ' . join( ' OR ', @$and_skels ) . ' )' ); } else { my $op = '='; my $val = $opts->{ $_ }; if( defined( $val ) && $val =~ s/^[[:blank:]\h]*(?\<|\<=|\>|\>=|=|\!=|\~)[[:blank:]\h]*(?.*?)$/$+{val}/ ) { $op = $+{op}; } elsif( defined( $val ) && ref( $val ) eq 'Regexp' ) { $op = '~'; $val =~ s/^\(\?[^\:]+\:(.*?)\)$/$1/; } $op = $op_map->{ $op } if( exists( $op_map->{ $op } ) ); if( $op eq '~' ) { push( @$skeleton, "$_ REGEXP(?)" ); push( @$by_keys, "regexp_${_}" ); } else { push( @$skeleton, "$_ ${op} ?" ); push( @$by_keys, "${op}${_}" ); } push( @$by_values, defined( $val ) ? ( Scalar::Util::blessed( $val ) && overload::Method( $val => '""' ) ) ? "$val" : $val : $val ); } } } if( defined( $status ) && exists( $opts->{ $status } ) ) { push( @$by, $status ); push( @$by_values, $opts->{ $status } ); push( @$skeleton, "${status} = ?" ); push( @$by_keys, "=${status}" ); } my( $has, $has_keys, $has_values ); if( $opts->{has} && scalar( @$sql_arrays_in ) ) { my $has_elems = []; if( ref( $opts->{has} ) eq 'HASH' ) { @$has_elems = %{$opts->{has}}; } elsif( ref( $opts->{has} ) eq 'ARRAY' ) { $has_elems = $opts->{has}; } elsif( scalar( @$sql_arrays_in ) == 1 ) { $has_elems = [ $sql_arrays_in->[0] => $opts->{has} ]; } else { return( $self->error( "There are ", scalar( @$sql_arrays_in ), " fields with array. You need to specify which one you want to check for value '", ( $opts->{has} // 'undef' ), "'" ) ); } $has = []; $has_keys = []; $has_values = []; for( my $i = 0; $i < scalar( @$has_elems ); $i += 2 ) { my $f = $has_elems->[$i]; unless( $f =~ /^[a-zA-z][a-zA-z0-9]+$/ ) { return( $self->error( "Invalid field name '${f}' for table '${table}'. It should only contain alpha numeric characters." ) ); } push( @$has_keys, $f ); push( @$has_values, $has_elems->[$i + 1] ); push( @$has, "EXISTS (SELECT * FROM JSON_EACH(${f}) WHERE JSON_EACH.value IS ?)" ); } } my $by_key = scalar( @$by_keys ) ? join( '_', @$by_keys ) : ''; my $sth_id = $by_key ? "${id}_with_${by_key}" . ( defined( $has ) ? '_has_' . join( '_', @$has_keys ) : '' ) . "_order_${order}" : defined( $has ) ? "${id}_with_has_" . join( '_', @$has_keys ) . "_order_${order}" : "${id}_order_${order}"; local $" = ', '; local $@; if( $by_key || defined( $has ) ) { unless( $sth = $self->_get_cached_statement( $sth_id ) ) { my $dbh = $self->_dbh || return( $self->pass_error ); $sth = eval { $dbh->prepare( "SELECT * FROM ${table} WHERE " . join( ' AND ', @$skeleton ) . ( defined( $has ) ? ( ( scalar( @$skeleton ) ? ' AND (' : '' ) . join( ' OR ', @$has ) . ( scalar( @$skeleton ) ? ')' : '' ) ) : '' ) . " ORDER BY ${order}" ) } || return( $self->error( "Unable to prepare SQL query to retrieve all ${what} information for fields @$by: ", ( $@ || $dbh->errstr ) ) ); $self->_set_cached_statement( $sth_id => $sth ); } } else { unless( $sth = $self->_get_cached_statement( $sth_id ) ) { my $dbh = $self->_dbh || return( $self->pass_error ); $sth = eval { $dbh->prepare( "SELECT * FROM ${table} ORDER BY ${order}" ) } || return( $self->error( "Unable to prepare SQL query to retrieve all ${what} information: ", ( $@ || $dbh->errstr ) ) ); $self->_set_cached_statement( $sth_id => $sth ); } } eval { $sth->execute( ( scalar( @$by_values ) ? @$by_values : () ), ( defined( $has_values ) ? @$has_values : () ) ) } || return( $self->error( "Error executing SQL query '$sth->{Statement}' to retrieve all ${what}". ( $by_key ? " with fields @$by" : '' ), ": ", ( $@ || $sth->errstr ), " with SQL query: ", $sth->{Statement} ) ); my $all = $sth->fetchall_arrayref({}); $self->_decode_utf8( $all ) if( MISSING_AUTO_UTF8_DECODING ); if( $all && scalar( @$sql_arrays_in ) ) { $self->_decode_sql_arrays( $sql_arrays_in, $all ) if( $self->{decode_sql_arrays} ); } if( !$all && want( 'ARRAY' ) ) { return( [] ); } return( $all ); } sub _fetch_one { my $self = shift( @_ ); my $def = shift( @_ ) || return( $self->error( "No hash definition provided." ) ); return( $self->error( "Hash definition is not an hash reference." ) ) if( ref( $def ) ne 'HASH' ); my $field = $def->{field} || return( $self->error( "No table field was provided." ) ); my $what = $def->{what} || $field; my $table = $def->{table} || return( $self->error( "No SQL table name was provided." ) ); my $defaults = $def->{default} || {}; my $opts = $self->_get_args_as_hash( @_ ); return( $self->error( "No ${what} ID provided to retrieve its information." ) ) if( !exists( $opts->{ $field } ) ); my $id = ref( $opts->{ $field } ) eq 'ARRAY' ? $opts->{ $field } : [$opts->{ $field }]; my $sql_arrays_in = ( exists( $def->{has_array} ) && ref( $def->{has_array} ) eq 'ARRAY' ? $def->{has_array} : [] ); my $requires = exists( $def->{requires} ) && ref( $def->{requires} ) eq 'ARRAY' ? $def->{requires} : []; # my $requires_key = scalar( @$requires ) ? join( '_', @$requires ) : ''; my $required_val = []; my $required_skel = []; my $required_keys = []; # In SQLite, the expression '= NULL' does not work, and we need to use 'IS NULL' my $op_map = { '=' => 'IS', '!=' => 'IS NOT', }; for( @$requires ) { return( $self->error( "Table field provided '$_' contains illegal characters." ) ) if( $_ !~ /^[a-z][a-z0-9]+(?:\_[a-z][a-z0-9]+)*$/ ); $opts->{ $_ } = $defaults->{ $_ } if( !exists( $opts->{ $_ } ) && exists( $defaults->{ $_ } ) ); if( !exists( $opts->{ $_ } ) ) { return( $self->error( "No value for $_ was provided." ) ); } if( ref( $opts->{ $_ } // '' ) eq 'ARRAY' ) { my $and_skels = []; for( my $i = 0; $i < scalar( @{$opts->{ $_ }} ); $i++ ) { my $op = '='; my $val = $opts->{ $_ }->[$i]; if( defined( $val ) && # $opts->{ $_ }->[$i] =~ s/^[[:blank:]\h]*(?\<|\<=|\>|\>=|=|\!=)[[:blank:]\h]*(?
\-?\d+.*?)$/$+{dt}/ ) $val =~ s/^[[:blank:]\h]*(?\<|\<=|\>|\>=|=|\!=|\~)[[:blank:]\h]*(?.*?)$/$+{val}/ ) { $op = $+{op}; } elsif( defined( $val ) && ref( $val ) eq 'Regexp' ) { $op = '~'; $val =~ s/^\(\?[^\:]+\:(.*?)\)$/$1/; } $op = $op_map->{ $op } if( exists( $op_map->{ $op } ) ); if( $op eq '~' ) { push( @$and_skels, "$_ REGEXP(?)" ); push( @$required_keys, "regexp_${_}" ); } else { push( @$and_skels, "$_ ${op} ?" ); push( @$required_keys, "${op}${_}" ); } push( @$required_val, defined( $val ) ? ( Scalar::Util::blessed( $val ) && overload::Method( $val => '""' ) ) ? "$val" : $val : $val ); } push( @$required_skel, '( ' . join( ' OR ', @$and_skels ) . ' )' ); } else { my $op = '='; my $val = $opts->{ $_ }; if( defined( $val ) && # $opts->{ $_ } =~ s/^[[:blank:]\h]*(?\<|\<=|\>|\>=|=|\!=\~)[[:blank:]\h]*(?
\-?\d+.*?)$/$+{dt}/ ) $val =~ s/^[[:blank:]\h]*(?\<|\<=|\>|\>=|=|\!=|\~)[[:blank:]\h]*(?.*?)$/$+{val}/ ) { $op = $+{op}; } elsif( defined( $val ) && ref( $val ) eq 'Regexp' ) { $op = '~'; $val =~ s/^\(\?[^\:]+\:(.*?)\)$/$1/; } $op = $op_map->{ $op } if( exists( $op_map->{ $op } ) ); if( $op eq '~' ) { push( @$required_skel, "$_ REGEXP(?)" ); push( @$required_keys, "regexp_${_}" ); } else { push( @$required_skel, "$_ ${op} ?" ); push( @$required_keys, "${op}${_}" ); } push( @$required_val, defined( $val ) ? ( Scalar::Util::blessed( $val ) && overload::Method( $val => '""' ) ) ? "$val" : $val : $val ); } } my $requires_key = scalar( @$required_keys ) ? join( '_', @$required_keys ) : ''; my $field_val = []; my $field_skel = []; my $field_keys = []; for( @$id ) { my $op = '='; if( defined( $_ ) && s/^[[:blank:]\h]*(?\<|\<=|\>|\>=|=|\!=|\~)[[:blank:]\h]*(?.*?)$/$+{val}/ ) { $op = $+{op}; } elsif( defined( $_ ) && ref( $_ ) eq 'Regexp' ) { $op = '~'; s/^\(\?[^\:]+\:(.*?)\)$/$1/; } $op = $op_map->{ $op } if( exists( $op_map->{ $op } ) ); if( $op eq '~' ) { push( @$field_skel, "${field} REGEXP(?)" ); push( @$field_keys, "regexp_field" ); } else { push( @$field_skel, "${field} ${op} ?" ); push( @$field_keys, "${op}${field}" ); } push( @$field_val, defined( $_ ) ? ( Scalar::Util::blessed( $_ ) && overload::Method( $_ => '""' ) ) ? "$_" : $_ : $_ ); } my $sth_id = ( $def->{id} ? $def->{id} . '_' : '' ) . join( '_', @$field_keys ); $sth_id .= '_' . $requires_key if( $requires_key ); my $sth; local $@; unless( $sth = $self->_get_cached_statement( $sth_id ) ) { my $dbh = $self->_dbh || return( $self->pass_error ); $sth = eval { $dbh->prepare( "SELECT * FROM ${table} WHERE (" . join( ' OR ', @$field_skel ) . ') ' . ( scalar( @$required_skel ) ? ' AND ' . join( ' AND ', @$required_skel ) : '' ) . ( $def->{multi} ? ' ORDER BY rowid' : '' ) ) } || return( $self->error( "Unable to prepare SQL query with statement ID ${sth_id} to retrieve a ${what} information: ", ( $@ || $dbh->errstr ) ) ); $self->_set_cached_statement( $sth_id => $sth ); } eval { $sth->execute( @$field_val, ( scalar( @$required_val ) ? @$required_val : () ) ); } || return( $self->error( "Error executing SQL query '$sth->{Statement}' with statement ID ${sth_id} to retrieve a ${what} information:", ( $@ || $sth->errstr ), " with SQL query: ", $sth->{Statement} ) ); my $ref = ( $def->{multi} || scalar( @$id ) > 1 ) ? $sth->fetchall_arrayref({}) : $sth->fetchrow_hashref; $self->_decode_utf8( $ref ) if( MISSING_AUTO_UTF8_DECODING ); if( $ref && scalar( @$sql_arrays_in ) ) { $self->_decode_sql_arrays( $sql_arrays_in, $ref ) if( $self->{decode_sql_arrays} ); } if( !$ref && want( 'HASH' ) ) { return( {} ); } return( $ref ); } sub _get_cached_statement { my $self = shift( @_ ); my $id = shift( @_ ); die( "No statement ID was provided to get its cached object." ) if( !length( $id // '' ) ); my $file = $self->datafile || $DB_FILE; $STHS->{ $file } //= {}; if( exists( $STHS->{ $file }->{ $id } ) && defined( $STHS->{ $file }->{ $id } ) && Scalar::Util::blessed( $STHS->{ $file }->{ $id } ) && $STHS->{ $file }->{ $id }->isa( 'DBI::st' ) ) { return( $STHS->{ $file }->{ $id } ); } return; } sub _get_metadata { my $self = shift( @_ ); my $prop = shift( @_ ) || die( "No metadata property provided." ); my $dbh = $self->_dbh || return( $self->pass_error ); my $sth; unless( $sth = $self->_get_cached_statement( 'cldr_metadata' ) ) { $sth = eval { $dbh->prepare( "SELECT value FROM metainfos WHERE property = ?" ) } || return( $self->error( "Unable to prepare query to get the CLDR built datetime from the SQLite database at ", $self->datafile, ": ", ( $@ || $dbh->errstr ) ) ); $self->_set_cached_statement( cldr_metadata => $sth ); } local $@; eval { $sth->execute( $prop ); } || return( $self->error( "Unable to execute query to get the CLDR property '${prop}' from the SQLite database at ", $self->datafile, ": ", ( $@ || $sth->errstr ) ) ); my $ref = $sth->fetchrow_arrayref; $self->_decode_utf8( $ref ) if( MISSING_AUTO_UTF8_DECODING ); return( '' ) if( !$ref ); return( $ref->[0] ); } sub _locale_object { my $self = shift( @_ ); my $locale = shift( @_ ) || return( $self->error( "No locale provided to ensure a Locale::Unicode." ) ); unless( Scalar::Util::blessed( $locale ) && $locale->isa( 'Locale::Unicode' ) ) { $locale = Locale::Unicode->new( $locale ) || return( $self->pass_error( Locale::Unicode->error ) ); } return( $locale ); } sub _set_cached_statement { my $self = shift( @_ ); my $id = shift( @_ ); my $sth = shift( @_ ); die( "No statement ID was provided to cache its object." ) if( !length( $id // '' ) ); if( !$sth ) { die( "No DBI statement handler was provided to cache with ID '${id}'" ); } elsif( !Scalar::Util::blessed( $sth ) || !$sth->isa( 'DBI::st' ) ) { die( "Value provided (", overload::StrVal( $sth ), ") is not a DBI statement object." ); } my $file = $self->datafile || $DB_FILE; $STHS->{ $file } //= {}; $STHS->{ $file }->{ $id } = $sth; return( $sth ); } sub _set_get_prop { my $self = shift( @_ ); my $field = shift( @_ ) || return( $self->error( "No field was provided." ) ); my( $re, $type, $isa ); if( ref( $field ) eq 'HASH' ) { my $def = $field; $field = $def->{field} || die( "No 'field' property was provided in the field dictionary hash reference." ); if( exists( $def->{regexp} ) && defined( $def->{regexp} ) && ref( $def->{regexp} ) eq 'Regexp' ) { $re = $def->{regexp}; } elsif( exists( $def->{type} ) && defined( $def->{type} ) && length( $def->{type} ) ) { $type = $def->{type}; } if( exists( $def->{isa} ) && defined( $def->{isa} ) && length( $def->{isa} ) ) { $isa = $def->{isa}; } } if( @_ ) { my $val = shift( @_ ); if( defined( $val ) && length( $val ) ) { if( defined( $re ) && $val !~ /^$re$/ ) { return( $self->error( "Invalid value provided for \"${field}\": ${val}" ) ); } elsif( defined( $type ) && $type eq 'boolean' ) { $val = lc( $val ); if( $val =~ /^(?:yes|no)$/i ) { $self->{_bool_types}->{ $field } = 'literal'; $val = ( $val eq 'yes' ? $self->true : $self->false ); } elsif( $val =~ /^(?:true|false)$/i ) { $self->{_bool_types}->{ $field } = 'logic'; $val = ( $val eq 'true' ? $self->true : $self->false ); } elsif( $val =~ /^(?:1|0)$/ ) { $self->{_bool_types}->{ $field } = 'logic'; $val = ( $val ? $self->true : $self->false ); } else { warn( "Unexpected value used as boolean for attribute \"${field}\": ${val}" ) if( warnings::enabled() ); $val = ( $val ? $self->true : $self->false ); } } elsif( defined( $isa ) ) { if( !Scalar::Util::blessed( $val ) || ( Scalar::Util::blessed( $val ) && !$val->isa( $isa ) ) ) { return( $self->error( "Value provided is not an ${isa} object." ) ); } } } $self->{ $field } = $val } # So chaining works rreturn( $self ) if( Want::want( 'OBJECT' ) ); # Returns undef in scalar context and an empty list in list context return if( !defined( $self->{ $field } ) ); return( $self->{ $field } ); } sub _get_args_as_hash { my $self = shift( @_ ); my $ref = {}; if( scalar( @_ ) == 1 && defined( $_[0] ) && ( ref( $_[0] ) || '' ) eq 'HASH' ) { $ref = shift( @_ ); } elsif( !( scalar( @_ ) % 2 ) ) { $ref = { @_ }; } else { die( "Uneven number of parameters provided." ); } return( $ref ); } # NOTE: END END { if( defined( $STHS ) && ref( $STHS ) eq 'HASH' ) { foreach my $db ( keys( %$STHS ) ) { foreach my $sth ( keys( %{$STHS->{ $db }} ) ) { if( defined( $sth ) && Scalar::Util::blessed( $sth ) ) { $sth->finish; } } } } }; sub FREEZE { my $self = CORE::shift( @_ ); my $serialiser = CORE::shift( @_ ) // ''; my $class = CORE::ref( $self ); my @keys = qw( datafile decode_sql_arrays fatal ); my %hash = (); @hash{ @keys } = @$self{ @keys }; # Return an array reference rather than a list so this works with Sereal and CBOR # On or before Sereal version 4.023, Sereal did not support multiple values returned CORE::return( [$class, %hash] ) if( $serialiser eq 'Sereal' && Sereal::Encoder->VERSION <= version->parse( '4.023' ) ); # But Storable want a list with the first element being the serialised element CORE::return( $class, \%hash ); } sub STORABLE_freeze { return( shift->FREEZE( @_ ) ); } sub STORABLE_thaw { return( shift->THAW( @_ ) ); } # NOTE: CBOR will call the THAW method with the stored classname as first argument, the constant string CBOR as second argument, and all values returned by FREEZE as remaining arguments. # NOTE: Storable calls it with a blessed object it created followed with $cloning and any other arguments initially provided by STORABLE_freeze sub THAW { my( $self, undef, @args ) = @_; my $ref = ( CORE::scalar( @args ) == 1 && CORE::ref( $args[0] ) eq 'ARRAY' ) ? CORE::shift( @args ) : \@args; my $class = ( CORE::defined( $ref ) && CORE::ref( $ref ) eq 'ARRAY' && CORE::scalar( @$ref ) > 1 ) ? CORE::shift( @$ref ) : ( CORE::ref( $self ) || $self ); my $hash = CORE::ref( $ref ) eq 'ARRAY' ? CORE::shift( @$ref ) : {}; my $new; # Storable pattern requires to modify the object it created rather than returning a new one if( CORE::ref( $self ) ) { foreach( CORE::keys( %$hash ) ) { $self->{ $_ } = CORE::delete( $hash->{ $_ } ); } $new = $self; } else { $new = CORE::bless( $hash => $class ); } CORE::return( $new ); } sub TO_JSON { my $self = CORE::shift( @_ ); my @keys = qw( datafile decode_sql_arrays ); my $hash = {}; @$hash{ @keys } = @$self{ @keys }; return( $hash ); } # NOTE: Locale::Unicode::Data::Boolean class package Locale::Unicode::Data::Boolean; BEGIN { use strict; use warnings; use vars qw( $VERSION $true $false ); use overload "0+" => sub{ ${$_[0]} }, "++" => sub{ $_[0] = ${$_[0]} + 1 }, "--" => sub{ $_[0] = ${$_[0]} - 1 }, fallback => 1; $true = do{ bless( \( my $dummy = 1 ) => 'Locale::Unicode::Data::Boolean' ) }; $false = do{ bless( \( my $dummy = 0 ) => 'Locale::Unicode::Data::Boolean' ) }; our $VERSION = 'v0.1.0'; }; use strict; use warnings; sub new { my $this = shift( @_ ); my $self = bless( \( my $dummy = ( $_[0] ? 1 : 0 ) ) => ( ref( $this ) || $this ) ); } sub clone { my $self = shift( @_ ); unless( ref( $self ) ) { die( "clone() must be called with an object." ); } my $copy = $$self; my $new = bless( \$copy => ref( $self ) ); return( $new ); } sub false() { $false } sub is_bool($) { UNIVERSAL::isa( $_[0], 'Locale::Unicode::Data::Boolean' ) } sub is_true($) { $_[0] && UNIVERSAL::isa( $_[0], 'Locale::Unicode::Data::Boolean' ) } sub is_false($) { !$_[0] && UNIVERSAL::isa( $_[0], 'Locale::Unicode::Data::Boolean' ) } sub true() { $true } sub FREEZE { my $self = CORE::shift( @_ ); my $serialiser = CORE::shift( @_ ) // ''; my $class = CORE::ref( $self ); # Return an array reference rather than a list so this works with Sereal and CBOR # On or before Sereal version 4.023, Sereal did not support multiple values returned CORE::return( [$class, $$self] ) if( $serialiser eq 'Sereal' && Sereal::Encoder->VERSION <= version->parse( '4.023' ) ); # But Storable want a list with the first element being the serialised element CORE::return( $$self ); } sub STORABLE_freeze { CORE::return( CORE::shift->FREEZE( @_ ) ); } sub STORABLE_thaw { CORE::return( CORE::shift->THAW( @_ ) ); } # NOTE: CBOR will call the THAW method with the stored classname as first argument, the constant string CBOR as second argument, and all values returned by FREEZE as remaining arguments. # NOTE: Storable calls it with a blessed object it created followed with $cloning and any other arguments initially provided by STORABLE_freeze sub THAW { my( $self, undef, @args ) = @_; my( $class, $str ); if( CORE::scalar( @args ) == 1 && CORE::ref( $args[0] ) eq 'ARRAY' ) { ( $class, $str ) = @{$args[0]}; } else { $class = CORE::ref( $self ) || $self; $str = CORE::shift( @args ); } # Storable pattern requires to modify the object it created rather than returning a new one if( CORE::ref( $self ) ) { $$self = $str; CORE::return( $self ); } else { CORE::return( $class->new( $str ) ); } } sub TO_JSON { # JSON does not check that the value is a proper true or false. It stupidly assumes this is a string # The only way to make it understand is to return a scalar ref of 1 or 0 # return( $_[0] ? 'true' : 'false' ); return( $_[0] ? \1 : \0 ); } # NOTE: Locale::Unicode::Data::Exception class package Locale::Unicode::Data::Exception; BEGIN { use strict; use warnings; use vars qw( $VERSION ); use overload ( '""' => 'as_string', bool => sub{ $_[0] }, fallback => 1, ); our $VERSION = 'v0.1.0'; }; use strict; use warnings; use overloading; sub new { my $this = shift( @_ ); my $self = bless( {} => ( ref( $this ) || $this ) ); my @info = caller; @$self{ qw( package file line ) } = @info[0..2]; my $args = {}; if( scalar( @_ ) == 1 ) { if( ( ref( $_[0] ) || '' ) eq 'HASH' ) { $args = shift( @_ ); if( $args->{skip_frames} ) { @info = caller( int( $args->{skip_frames} ) ); @$self{ qw( package file line ) } = @info[0..2]; } $args->{message} ||= ''; foreach my $k ( qw( package file line message code type retry_after ) ) { $self->{ $k } = $args->{ $k } if( CORE::exists( $args->{ $k } ) ); } } elsif( ref( $_[0] ) && $_[0]->isa( 'Locale::Unicode::Data::Exception' ) ) { my $o = $args->{object} = shift( @_ ); $self->{message} = $o->message; $self->{code} = $o->code; $self->{type} = $o->type; $self->{retry_after} = $o->retry_after; } else { die( "Unknown argument provided: '", overload::StrVal( $_[0] ), "'" ); } } else { $args->{message} = join( '', map( ref( $_ ) eq 'CODE' ? $_->() : $_, @_ ) ); } return( $self ); } # This is important as stringification is called by die, so as per the manual page, we need to end with new line # And will add the stack trace sub as_string { no overloading; my $self = shift( @_ ); return( $self->{_cache_value} ) if( $self->{_cache_value} && !CORE::length( $self->{_reset} ) ); my $str = $self->message; $str = "$str"; $str =~ s/\r?\n$//g; $str .= sprintf( " within package %s at line %d in file %s", ( $self->{package} // 'undef' ), ( $self->{line} // 'undef' ), ( $self->{file} // 'undef' ) ); $self->{_cache_value} = $str; CORE::delete( $self->{_reset} ); return( $str ); } sub code { return( shift->reset(@_)->_set_get_prop( 'code', @_ ) ); } sub file { return( shift->reset(@_)->_set_get_prop( 'file', @_ ) ); } sub line { return( shift->reset(@_)->_set_get_prop( 'line', @_ ) ); } sub message { return( shift->reset(@_)->_set_get_prop( 'message', @_ ) ); } sub package { return( shift->reset(@_)->_set_get_prop( 'package', @_ ) ); } # From perlfunc docmentation on "die": # "If LIST was empty or made an empty string, and $@ contains an # object reference that has a "PROPAGATE" method, that method will # be called with additional file and line number parameters. The # return value replaces the value in $@; i.e., as if "$@ = eval { # $@->PROPAGATE(__FILE__, __LINE__) };" were called." sub PROPAGATE { my( $self, $file, $line ) = @_; if( defined( $file ) && defined( $line ) ) { my $clone = $self->clone; $clone->file( $file ); $clone->line( $line ); return( $clone ); } return( $self ); } sub reset { my $self = shift( @_ ); if( !CORE::length( $self->{_reset} ) && scalar( @_ ) ) { $self->{_reset} = scalar( @_ ); } return( $self ); } sub rethrow { my $self = shift( @_ ); return if( !ref( $self ) ); die( $self ); } sub retry_after { return( shift->_set_get_prop( 'retry_after', @_ ) ); } sub throw { my $self = shift( @_ ); my $e; if( @_ ) { my $msg = shift( @_ ); $e = $self->new({ skip_frames => 1, message => $msg, }); } else { $e = $self; } die( $e ); } sub type { return( shift->reset(@_)->_set_get_prop( 'type', @_ ) ); } sub _set_get_prop { my $self = shift( @_ ); my $prop = shift( @_ ) || die( "No object property was provided." ); $self->{ $prop } = shift( @_ ) if( @_ ); return( $self->{ $prop } ); } sub FREEZE { my $self = CORE::shift( @_ ); my $serialiser = CORE::shift( @_ ) // ''; my $class = CORE::ref( $self ); my %hash = %$self; # Return an array reference rather than a list so this works with Sereal and CBOR # On or before Sereal version 4.023, Sereal did not support multiple values returned CORE::return( [$class, \%hash] ) if( $serialiser eq 'Sereal' && Sereal::Encoder->VERSION <= version->parse( '4.023' ) ); # But Storable want a list with the first element being the serialised element CORE::return( $class, \%hash ); } sub STORABLE_freeze { return( shift->FREEZE( @_ ) ); } sub STORABLE_thaw { return( shift->THAW( @_ ) ); } # NOTE: CBOR will call the THAW method with the stored classname as first argument, the constant string CBOR as second argument, and all values returned by FREEZE as remaining arguments. # NOTE: Storable calls it with a blessed object it created followed with $cloning and any other arguments initially provided by STORABLE_freeze sub THAW { my( $self, undef, @args ) = @_; my $ref = ( CORE::scalar( @args ) == 1 && CORE::ref( $args[0] ) eq 'ARRAY' ) ? CORE::shift( @args ) : \@args; my $class = ( CORE::defined( $ref ) && CORE::ref( $ref ) eq 'ARRAY' && CORE::scalar( @$ref ) > 1 ) ? CORE::shift( @$ref ) : ( CORE::ref( $self ) || $self ); my $hash = CORE::ref( $ref ) eq 'ARRAY' ? CORE::shift( @$ref ) : {}; my $new; # Storable pattern requires to modify the object it created rather than returning a new one if( CORE::ref( $self ) ) { foreach( CORE::keys( %$hash ) ) { $self->{ $_ } = CORE::delete( $hash->{ $_ } ); } $new = $self; } else { $new = CORE::bless( $hash => $class ); } CORE::return( $new ); } sub TO_JSON { return( shift->as_string ); } { # NOTE: Locale::Unicode::Data::NullObject class package Locale::Unicode::Data::NullObject; BEGIN { use strict; use warnings; use overload ( '""' => sub{ '' }, fallback => 1, ); use Want; }; use strict; use warnings; sub new { my $this = shift( @_ ); my $ref = @_ ? { @_ } : {}; return( bless( $ref => ( ref( $this ) || $this ) ) ); } sub AUTOLOAD { my( $method ) = our $AUTOLOAD =~ /([^:]+)$/; my $self = shift( @_ ); if( Want::want( 'OBJECT' ) ) { rreturn( $self ); } # Otherwise, we return undef; Empty return returns undef in scalar context and empty list in list context return; }; } 1; # NOTE: POD __END__ =encoding utf-8 =head1 NAME Locale::Unicode::Data - Unicode CLDR SQL Data =head1 SYNOPSIS use Locale::Unicode::Data; my $cldr = Locale::Unicode::Data->new; # Do not decode SQL arrays into perl arrays. Defaults to true # This uses JSON::XS my $cldr = Locale::Unicode::Data->new( decode_sql_arrays => 0 ); my $datetime = $cldr->cldr_built; my $str = $cldr->cldr_maintainer; my $version = $cldr->cldr_version; my $dbh = $cldr->database_handler; my $sqlite_db_file = $cldr->datafile; my $bool = $cldr->decode_sql_arrays; # Deactivate automatic SQL arrays decoding $cldr->decode_sql_arrays(0); my $tree = $cldr->make_inheritance_tree( 'ja-JP' ); # ['ja-JP', 'ja', 'und'] my $tree = $cldr->make_inheritance_tree( 'es-Latn-001-valencia' ); # ['es-Latn-001-valencia', 'es-Latn-001', 'es-Latn', 'es', 'und'] # But... my $tree = $cldr->make_inheritance_tree( 'pt-FR' ); # Because exceptionally, the parent of 'pt-FR' is not 'pt', but 'pt-PT' # ['pt-FR', 'pt-PT', 'pt', 'und'] my $ref = $cldr->split_interval( pattern => "E, MMM d, y – E, MMM d, y G", greatest_diff => 'y', ); # ["E, MMM d, y", " – ", "E, MMM d, y G", "E, MMM d, y"] my $ref = $cldr->alias( alias => 'fro', type => 'subdivision', ); # For 'Hauts-de-France' my $all = $cldr->aliases; # 'type' can be one of territory, language, zone, subdivision, variant, script my $all = $cldr->aliases( type => 'territory' ); my $ref = $cldr->annotation( annotation => '{', locale => 'en' ); my $all = $cldr->annotations; # Get all annotations for locale 'en' my $all = $cldr->annotations( locale => 'en' ); my $ref = $cldr->bcp47_currency( currid => 'jpy' ); my $all = $cldr->bcp47_currencies; my $all = $cldr->bcp47_currencies( code => 'JPY' ); # Get all obsolete BCP47 currencies my $all = $cldr->bcp47_currencies( is_obsolete => 1 ); my $ref = $cldr->bcp47_extension( extension => 'ca' ); my $all = $cldr->bcp47_extensions; # Get all deprecated BCP47 extensions my $all = $cldr->bcp47_extensions( deprecated => 1 ); my $ref = $cldr->bcp47_timezone( tzid => 'jptyo' ); my $all = $cldr->bcp47_timezones; # Get all deprecated BCP47 timezones my $all = $cldr->bcp47_timezones( deprecated => 1 ); # Returns information about Japanese Imperial calendar my $ref = $cldr->bcp47_value( value => 'japanese' ); my $all = $cldr->bcp47_timezones; # Get all the BCP47 values for the category 'calendar' my $all = $cldr->bcp47_values( category => 'calendar' ); my $all = $cldr->bcp47_values( extension => 'ca' ); my $ref = $cldr->calendar( calendar => 'gregorian' ); my $all = $cldr->calendars; # Known 'system' value: undef, lunar, lunisolar, other, solar my $all = $cldr->calendars( system => 'solar' ); my $ref = $cldr->calendar_append_format( locale => 'en', calendar => 'gregorian', format_id => 'Day', ); my $all = $cldr->calendar_append_formats; my $all = $cldr->calendar_append_formats( locale => 'en', calendar => 'gregorian', ); my $ref = $cldr->calendar_available_format( locale => 'en', calendar => 'gregorian', format_id => 'Hms', count => undef, alt => undef, ); my $all = $cldr->calendar_available_formats; my $all = $cldr->calendar_available_formats( locale => 'en', calendar => 'gregorian' ); my $ref = $cldr->calendar_cyclic_l10n( locale => 'und', calendar => 'chinese', format_set => 'dayParts', format_type => 'format', format_length => 'abbreviated', format_id => 1, ); my $all = $cldr->calendar_cyclics_l10n; my $all = $cldr->calendar_cyclics_l10n( locale => 'en' ); my $all = $cldr->calendar_cyclics_l10n( locale => 'en', calendar => 'chinese', format_set => 'dayParts', # Not really needed since 'format' is the only value being currently used # format_type => 'format', format_length => 'abbreviated', ); my $all = $cldr->calendar_datetime_formats; my $all = $cldr->calendar_datetime_formats( locale => 'en', calendar => 'gregorian', ); my $ref = $cldr->calendar_era( calendar => 'japanese', sequence => 236, ); # Current era 'reiwa' my $ref = $cldr->calendar_era( calendar => 'japanese', code => 'reiwa', ); # Current era 'reiwa' my $all = $cldr->calendar_eras; my $all = $cldr->calendar_eras( calendar => 'hebrew' ); my $ref = $cldr->calendar_format_l10n( locale => 'en', calendar => 'gregorian', format_type => 'date', format_length => 'full', format_id => 'yMEEEEd', ); my $ref = $cldr->calendar_era_l10n( locale => 'ja', calendar => 'gregorian', era_width => 'abbreviated', alt => undef, era_id => 0, ); my $array_ref = $cldr->calendar_eras_l10n; # Filter based on the 'locale' field value my $array_ref = $cldr->calendar_eras_l10n( locale => 'en' ); # Filter based on the 'calendar' field value my $array_ref = $cldr->calendar_eras_l10n( calendar => 'gregorian' ); # or a combination of multiple fields: my $array_ref = $cldr->calendar_eras_l10n( locale => 'en', calendar => 'gregorian', era_width => 'abbreviated', alt => undef ); my $ref = $cldr->calendar_format_l10n( locale => 'en', calendar => 'gregorian', # date, time format_type => 'date', # full, long, medium, short format_length => 'full', format_id => 'yMEEEEd', ); my $all = $cldr->calendar_formats_l10n; my $all = $cldr->calendar_formats_l10n( locale => 'en', calendar => 'gregorian', ); my $all = $cldr->calendar_formats_l10n( locale => 'en', calendar => 'gregorian', format_type => 'date', format_length => 'full', ); my $ref = $cldr->calendar_interval_format( locale => 'en', calendar => 'gregorian', greatest_diff_id => 'd', format_id => 'GyMMMEd', alt => undef, ); my $all = $cldr->calendar_interval_formats; my $all = $cldr->calendar_interval_formats( locale => 'en', calendar => 'gregorian', ); my $ref = $cldr->calendar_term( locale => 'und', calendar => 'gregorian', # format, stand-alone term_context => 'format', # abbreviated, narrow, wide term_width => 'abbreviated', term_name => 'am', ); my $array_ref = $cldr->calendar_terms; my $array_ref = $cldr->calendar_terms( locale => 'und', calendar => 'japanese' ); my $array_ref = $cldr->calendar_terms( locale => 'und', calendar => 'gregorian', term_type => 'day', term_context => 'format', term_width => 'abbreviated', ); my $ref = $cldr->casing( locale => 'fr', token => 'currencyName' ); my $all = $cldr->casings; my $all = $cldr->casings( locale => 'fr' ); my $ref = $cldr->code_mapping( code => 'US' ); my $all = $cldr->code_mappings; my $all = $cldr->code_mappings( type => 'territory' ); my $all = $cldr->code_mappings( type => 'currency' ); my $all = $cldr->code_mappings( alpha3 => 'USA' ); my $all = $cldr->code_mappings( numeric => 840 ); # U.S.A. my $all = $cldr->code_mappings( numeric => [">835", "<850"] ); # U.S.A. my $all = $cldr->code_mappings( fips => 'JP' ); # Japan my $all = $cldr->code_mappings( fips => undef, type => 'currency' ); my $ref = $cldr->collation( collation => 'ducet' ); my $all = $cldr->collations; my $all = $cldr->collations( description => qr/Chinese/ ); my $ref = $cldr->collation_l10n( locale => 'en', collation => 'ducet' ); my $all = $cldr->collations_l10n( locale => 'en' ); my $all = $cldr->collations_l10n( locale => 'ja', locale_name => qr/中国語/ ); my $ref = $cldr->currency( currency => 'JPY' ); # Japanese Yen my $all = $cldr->currencies; my $all = $cldr->currencies( is_obsolete => 1 ); my $ref = $cldr->currency_info( territory => 'FR', currency => 'EUR' ); my $all = $cldr->currencies_info; my $all = $cldr->currencies_info( territory => 'FR' ); my $all = $cldr->currencies_info( currency => 'EUR' ); my $ref = $cldr->currency_l10n( locale => 'en', count => undef, currency => 'JPY', ); my $all = $cldr->currencies_l10n; my $all = $cldr->currencies_l10n( locale => 'en' ); my $all = $cldr->currencies_l10n( locale => 'en', currency => 'JPY', ); my $ref = $cldr->date_field_l10n( locale => 'en', field_type => 'day', field_length => 'narrow', relative => -1, ); my $all = $cldr->date_fields_l10n; my $all = $cldr->date_fields_l10n( locale => 'en' ); my $all = $cldr->date_fields_l10n( locale => 'en', field_type => 'day', field_length => 'narrow', ); my $ref = $cldr->day_period( locale => 'fr', day_period => 'noon' ); my $all = $cldr->day_periods; my $all = $cldr->day_periods( locale => 'ja' ); # Known values for day_period: afternoon1, afternoon2, am, evening1, evening2, # midnight, morning1, morning2, night1, night2, noon, pm my $all = $cldr->day_periods( day_period => 'noon' ); my $ids = $cldr->interval_formats( locale => 'en', calendar => 'gregorian', ); # Retrieve localised information for certain type of data # Possible types are: annotation, calendar_append_format, calendar_available_format, # calendar_cyclic, calendar_era, calendar_format, calendar_interval_formats, # calendar_term, casing, currency, date_field, locale, number_format, number_symbol # script, subdivision, territory, unit, variant my $ref = $cldr->l10n( type => 'annotation', locale => 'en', annotation => '{', ); my $ref = $cldr->l10n( # or just 'append' type => 'calendar_append_format', locale => 'en', calendar => 'gregorian', format_id => 'Day', ); my $ref = $cldr->l10n( # or just 'available' type => 'calendar_available_format', locale => 'ja', calendar => 'japanese', format_id => 'GyMMMEEEEd', ); my $ref = $cldr->l10n( # or just 'cyclic' type => 'calendar_cyclic', locale => 'ja', calendar => 'chinese', format_set => 'dayParts', # 1..12 format_id => 1, ); # Retrieve the information on current Japanese era (Reiwa) my $ref = $cldr->l10n( # or just 'era' type => 'calendar_era', locale => 'ja', calendar => 'japanese', # abbreviated, narrow # 'narrow' contains less data than 'abbreviated' era_width => 'abbreviated', era_id => 236, ); my $ref = $cldr->l10n( type => 'calendar_format', locale => 'ja', calendar => 'gregorian', format_id => 'yMEEEEd', ); my $ref = $cldr->l10n( # or just 'interval' type => 'calendar_interval_format', locale => 'ja', calendar => 'gregorian', format_id => 'yMMM', ); my $ref = $cldr->l10n( type => 'calendar_term', locale => 'ja', calendar => 'gregorian', term_name => 'mon', ); my $ref = $cldr->l10n( type => 'casing', locale => 'fr', token => 'currencyName', ); my $ref = $cldr->l10n( type => 'currency', locale => 'ja', currency => 'EUR', ); my $ref = $cldr->l10n( # or just 'field' type => 'date_field', locale => 'ja', # Other possible values: # day, week, month, quarter, year, hour, minute, second, # mon, tue, wed, thu, fri, sat, sun field_type => 'day', # -1 for yesterday, 0 for today, 1 for tomorrow relative => -1, ); my $ref = $cldr->l10n( type => 'locale', locale => 'ja', locale_id => 'fr', ); my $ref = $cldr->l10n( type => 'number_format', locale => 'ja', number_type => 'currency', format_id => '10000', ); my $ref = $cldr->l10n( # or just 'symbol' type => 'number_symbol', locale => 'en', number_system => 'latn', property => 'decimal', ); my $ref = $cldr->l10n( type => 'script', locale => 'ja', script => 'Kore', ); my $ref = $cldr->l10n( type => 'subdivision', locale => 'en', subdivision => 'jp13', # Tokyo ); my $ref = $cldr->l10n( type => 'territory', locale => 'en', territory => 'JP', # Japan ); my $ref = $cldr->l10n( type => 'unit', locale => 'en', unit_id => 'power3', ); my $ref = $cldr->l10n( type => 'variant', locale => 'en', variant => 'valencia', ); my $ref = $cldr->language( language => 'ryu' ); # Central Okinawan (Ryukyu) my $all = $cldr->languages; my $all = $cldr->languages( parent => 'gmw' ); my $all = $cldr->language_population( territory => 'JP' ); my $all = $cldr->language_populations; my $all = $cldr->language_populations( official_status => 'official' ); my $ref = $cldr->likely_subtag( locale => 'ja' ); my $all = $cldr->likely_subtags; my $ref = $cldr->locale( locale => 'ja' ); my $all = $cldr->locales; my $ref = $cldr->locale_l10n( locale => 'en', locale_id => 'ja', alt => undef, ); my $all = $cldr->locales_l10n; # Returns an array reference of all locale information in English my $all = $cldr->locales_l10n( locale => 'en' ); # Returns an array reference of all the way to write 'Japanese' in various languages # This would typically return an array reference of something like 267 hash reference my $all = $cldr->locales_l10n( locale_id => 'ja' ); # This is basically the same as with the method locale_l10n() my $all = $cldr->locales_l10n( locale => 'en', locale_id => 'ja', alt => undef, ); my $ref = $cldr->locales_info( property => 'quotation_start', locale => 'ja' ); my $all = $cldr->locales_infos; my $ref = $cldr->metazone( metazone => 'Japan' ); my $all = $cldr->metazones; my $ref = $cldr->number_format_l10n( locale => 'en', number_system => 'latn', number_type => 'currency', format_length => 'short', format_type => 'standard', alt => undef, count => 'one', format_id => 1000, ); my $all = $cldr->number_formats_l10n; my $all = $cldr->number_formats_l10n( locale => 'en' ); my $all = $cldr->number_formats_l10n( locale => 'en', number_system => 'latn', number_type => 'currency', format_length => 'short', format_type => 'standard', ); my $ref = $cldr->number_symbol_l10n( locale => 'en', number_system => 'latn', property => 'decimal', alt => undef, ); my $all = $cldr->number_symbols_l10n; my $all = $cldr->number_symbols_l10n( locale => 'en' ); my $all = $cldr->number_symbols_l10n( locale => 'en', number_system => 'latn', ); # See also using rbnf my $ref = $cldr->number_system( number_system => 'jpan' ); my $all = $cldr->number_systems; my $ref = $cldr->person_name_default( locale => 'ja' ); my $all = $cldr->person_name_defaults; my $ref = $cldr->rbnf( locale => 'ja', ruleset => 'spellout-cardinal', rule_id => 7, ); my $all = $cldr->rbnfs; my $all = $cldr->rbnfs( locale => 'ko' ); my $all = $cldr->rbnfs( grouping => 'SpelloutRules' ); my $all = $cldr->rbnfs( ruleset => 'spellout-cardinal-native' ); my $ref = $cldr->reference( code => 'R1131' ); my $all = $cldr->references; my $ref = $cldr->script( script => 'Jpan' ); my $all = $cldr->scripts; # 'rtl' ('right-to-left' writing orientation) my $all = $cldr->scripts( rtl => 1 ); my $all = $cldr->scripts( origin_country => 'FR' ); my $all = $cldr->scripts( likely_language => 'fr' ); my $ref = $cldr->script_l10n( locale => 'en', script => 'Latn', alt => undef, ); my $all = $cldr->scripts_l10n; my $all = $cldr->scripts_l10n( locale => 'en' ); my $all = $cldr->scripts_l10n( locale => 'en', alt => undef, ); my $ref = $cldr->subdivision( subdivision => 'jp12' ); my $all = $cldr->subdivisions; my $all = $cldr->subdivisions( territory => 'JP' ); my $all = $cldr->subdivisions( parent => 'US' ); my $all = $cldr->subdivisions( is_top_level => 1 ); my $ref = $cldr->subdivision_l10n( locale => 'en', # Texas subdivision => 'ustx', ); my $all = $cldr->subdivisions_l10n; my $all = $cldr->subdivisions_l10n( locale => 'en' ); my $ref = $cldr->territory( territory => 'FR' ); my $all = $cldr->territories; my $all = $cldr->territories( parent => 150 ); my $ref = $cldr->territory_l10n( locale => 'en', territory => 'JP', alt => undef, ); my $all = $cldr->territories_l10n; my $all = $cldr->territories_l10n( locale => 'en' ); my $all = $cldr->territories_l10n( locale => 'en', alt => undef, ); my $ref = $cldr->time_format( region => 'JP' ); my $all = $cldr->time_formats; my $all = $cldr->time_formats( region => 'US' ); my $all = $cldr->time_formats( territory => 'JP' ); my $all = $cldr->time_formats( locale => undef ); my $all = $cldr->time_formats( locale => 'en' ); my $ref = $cldr->timezone( timezone => 'Asia/Tokyo' ); my $all = $cldr->timezones; my $all = $cldr->timezones( territory => 'US' ); my $all = $cldr->timezones( region => 'Asia' ); my $all = $cldr->timezones( tzid => 'sing' ); my $all = $cldr->timezones( tz_bcpid => 'sgsin' ); my $all = $cldr->timezones( metazone => 'Singapore' ); my $all = $cldr->timezones( is_golden => undef ); my $all = $cldr->timezones( is_golden => 1 ); my $all = $cldr->timezones( is_primary => 1 ); my $all = $cldr->timezones( is_canonical => 1 ); my $ref = $cldr->timezone_city( locale => 'fr', timezone => 'Asia/Tokyo', ); my $all = $cldr->timezones_cities; my $ref = $cldr->timezone_info( timezone => 'Asia/Tokyo', start => undef, ); my $ref = $cldr->timezone_info( timezone => 'Europe/Simferopol', start => ['>1991-01-01', '<1995-01-01'], ); my $all = $cldr->timezones_info; my $all = $cldr->timezones_info( metazone => 'Singapore' ); my $all = $cldr->timezones_info( start => undef ); my $all = $cldr->timezones_info( until => undef ); my $ref = $cldr->unit_alias( alias => 'meter-per-second-squared' ); my $all = $cldr->unit_aliases; my $ref = $cldr->unit_constant( constant => 'lb_to_kg' ); my $all = $cldr->unit_constants; my $ref = $cldr->unit_conversion( source => 'kilogram' ); my $all = $cldr->unit_conversions; my $all = $cldr->unit_conversions( base_unit => 'kilogram' );; my $all = $cldr->unit_conversions( category => 'kilogram' ); my $ref = $cldr->unit_l10n( locale => 'en', # long, narrow, short format_length => 'long', # compound, regular unit_type => 'regular', unit_id => 'length-kilometer', count => 'one', gender => undef, gram_case => undef, ); my $all = $cldr->units_l10n; my $all = $cldr->units_l10n( locale => 'en' ); my $all = $cldr->units_l10n( locale => 'en', format_length => 'long', unit_type => 'regular', unit_id => 'length-kilometer', pattern_type => 'regular', ); my $ref = $cldr->unit_prefix( unit_id => 'micro' ); my $all = $cldr->unit_prefixes; my $ref = $cldr->unit_pref( unit_id => 'square-meter' ); my $all = $cldr->unit_prefs; my $all = $cldr->unit_prefs( territory => 'US' ); my $all = $cldr->unit_prefs( category => 'area' ); my $ref = $cldr->unit_quantity( base_unit => 'kilogram' ); my $all = $cldr->unit_quantities; my $all = $cldr->unit_quantities( quantity => 'mass' ); my $ref = $cldr->variant( variant => 'valencia' ); my $all = $cldr->variants; my $ref = $cldr->variant_l10n( locale => 'en', alt => undef, variant => 'valencia', ); my $all = $cldr->variants_l10n; my $all = $cldr->variants_l10n( locale => 'en' ); my $all = $cldr->variants_l10n( locale => 'en', alt => undef, ); my $ref = $cldr->week_preference( locale => 'ja' ); my $all = $cldr->week_preferences; With advanced search: my $all = $cldr->timezone_info( timezone => 'Europe/Simferopol', start => ['>1991-01-01','<1995-01-01'], ); my $all = $cldr->time_formats( region => '~^U.*', ); my $all = $cldr->time_formats( region => qr/^U.*/, ); Enabling fatal exceptions: use v5.34; use experimental 'try'; no warnings 'experimental'; try { my $locale = Locale::Unicode::Data->new( fatal => 1 ); # Missing the 'width' argument my $str = $cldr->timezone_names( timezone => 'Asia/Tokyo', locale => 'en' ); # More code } catch( $e ) { say "Oops: ", $e->message; } Or, you could set the global variable C<$FATAL_EXCEPTIONS> instead: use v5.34; use experimental 'try'; no warnings 'experimental'; $Locale::Unicode::Data::FATAL_EXCEPTIONS = 1; try { my $locale = Locale::Unicode::Data->new; # Missing the 'width' argument my $str = $cldr->timezone_names( timezone => 'Asia/Tokyo', locale => 'en' ); # More code } catch( $e ) { say "Oops: ", $e->message; } =head1 VERSION v1.4.0 =head1 DESCRIPTION C provides access to all the data from the Unicode L (Common Locale Data Repository), using a SQLite database. This is the most extensive up-to-date L data you will find on C. It is provided as SQLite data with a great many number of methods to access those data and make it easy for you to retrieve them. Thanks to SQLite, it is very fast. SQLite version C<3.6.19> (2009-10-14) or higher is required, as this module relies on foreign keys, which were not fully supported before. If the version is anterior, the module will return an error upon object instantiation. It is designed to be extensive in the scope of data that can be accessed, while at the same time, memory-friendly. Access to each method returns data from the SQLite database on a need-basis. All the data in this SQLite database are sourced directly and exclusively from the Unicode official L data using a perl script available in this distribution under the C directory. Use C or C to access its POD documentation. The C data includes, by design, outdated ones, such as outdated currencies, country codes, or timezones, that C keeps in order to ensure consistency and reliability. For example, for timezones, the Unicode C (Locale Data Markup Language) states that "CLDR contains locale data using a time zone ID from the tz database as the key, stability of the IDs is critical." and "Not all TZDB links are in CLDR aliases. CLDR purposefully does not exactly match the Link structure in the TZDB.". See L In C parlance, a L is a 2 to 3-characters identifier, whereas a C includes more information, such as a C, a C