# Support RFC 3066 language tags, which use '-' instead of '_'.
$name =~ tr/-/_/;
my $key = $name;
return $LoadCache{$key} if exists $LoadCache{$key};
# Custom class registered by user
if ( $Class{$name} )
{
return $LoadCache{$key} = $class->_load_class_from_id( $name, $Class{$name} )
}
# special case for backwards compatibility with DT::Language
$name = $OldAliases{$name} if exists $OldAliases{$name};
if ( exists $DataForID{$name} || exists $AliasToID{$name} )
{
return $LoadCache{$key} = $class->_load_class_from_id($name);
}
foreach my $h ( \%NameToID, \%NativeNameToID )
{
return $LoadCache{$key} = $class->_load_class_from_id( $h->{$name} )
if exists $h->{$name};
}
if ( my $id = $class->_guess_id($name) )
{
return $LoadCache{$key} = $class->_load_class_from_id($id);
}
die "Invalid locale name or id: $name\n";
}
sub _guess_id
{
my $class = shift;
my $name = shift;
# Strip off charset for LC_* ids : en_GB.UTF-8 etc
$name =~ s/\..*$//;
my ($language, $script, $territory, $variant ) =
parse_id($name);
my @guesses;
if ( defined $script )
{
my $guess = join '_', lc $language, ucfirst lc $script;
push @guesses, $guess;
$guess .= '_' . uc $territory if defined $territory;
# version with script comes first
unshift @guesses, $guess;
}
if ( defined $variant )
{
push @guesses,
join '_', lc $language, uc $territory, uc $variant;
}
if ( defined $territory )
{
push @guesses,
join '_', lc $language, uc $territory;
}
push @guesses, lc $language;
foreach my $id (@guesses)
{
return $id
if exists $DataForID{$id} || exists $AliasToID{$id};
}
}
sub parse_id
{
$_[0] =~ /([a-z]+) # id
(?: _([A-Z][a-z]+) )? # script - Title Case - optional
(?: _([A-Z]+) )? # territory - ALL CAPS - optional
(?: _([A-Z]+) )? # variant - ALL CAPS - optional
/x;
return $1, $2, $3, $4;
}
sub _load_class_from_id
{
my $class = shift;
my $id = shift;
my $real_class = shift;
# We want the first alias for which there is data, even if it has
# no corresponding .pm file. There may be multiple levels of
=3= |