summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Locale/Codes.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Locale/Codes.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/Locale/Codes.pm628
1 files changed, 628 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Locale/Codes.pm b/Master/tlpkg/tlperl/lib/Locale/Codes.pm
new file mode 100644
index 00000000000..2fe84b1994c
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Locale/Codes.pm
@@ -0,0 +1,628 @@
+package Locale::Codes;
+# Copyright (C) 2001 Canon Research Centre Europe (CRE).
+# Copyright (C) 2002-2009 Neil Bowers
+# Copyright (c) 2010-2011 Sullivan Beck
+# This program is free software; you can redistribute it and/or modify it
+# under the same terms as Perl itself.
+
+use strict;
+use warnings;
+require 5.002;
+
+use Carp;
+
+#=======================================================================
+# Public Global Variables
+#=======================================================================
+
+# This module is not called directly... %Data is filled in by the
+# calling modules.
+
+our($VERSION,%Data);
+
+# $Data{ TYPE }{ code2id }{ CODESET } { CODE } = [ ID, I ]
+# { id2code }{ CODESET } { ID } = CODE
+# { id2names }{ ID } = [ NAME, NAME, ... ]
+# { alias2id }{ NAME } = [ ID, I ]
+# { id } = FIRST_UNUSED_ID
+# { codealias }{ CODESET } { ALIAS } = CODE
+
+$VERSION='3.16';
+
+#=======================================================================
+#
+# _code2name ( TYPE,CODE,CODESET )
+#
+#=======================================================================
+
+sub _code2name {
+ my($type,$code,$codeset) = @_;
+
+ $code = $Data{$type}{'codealias'}{$codeset}{$code}
+ if (exists $Data{$type}{'codealias'}{$codeset}{$code});
+
+ if (exists $Data{$type}{'code2id'}{$codeset} &&
+ exists $Data{$type}{'code2id'}{$codeset}{$code}) {
+ my ($id,$i) = @{ $Data{$type}{'code2id'}{$codeset}{$code} };
+ my $name = $Data{$type}{'id2names'}{$id}[$i];
+ return $name;
+ } else {
+ #---------------------------------------------------------------
+ # no such code!
+ #---------------------------------------------------------------
+ return undef;
+ }
+}
+
+#=======================================================================
+#
+# _name2code ( TYPE,NAME,CODESET )
+#
+#=======================================================================
+
+sub _name2code {
+ my($type,$name,$codeset) = @_;
+ $name = "" if (! $name);
+ $name = lc($name);
+
+ if (exists $Data{$type}{'alias2id'}{$name}) {
+ my $id = $Data{$type}{'alias2id'}{$name}[0];
+ if (exists $Data{$type}{'id2code'}{$codeset}{$id}) {
+ return $Data{$type}{'id2code'}{$codeset}{$id};
+ }
+ }
+
+ #---------------------------------------------------------------
+ # no such name!
+ #---------------------------------------------------------------
+ return undef;
+ }
+
+#=======================================================================
+#
+# _code2code ( TYPE,CODE,CODESET )
+#
+#=======================================================================
+
+sub _code2code {
+ my($type,$code,$inset,$outset) = @_;
+
+ my $name = _code2name($type,$code,$inset);
+ my $outcode = _name2code($type,$name,$outset);
+ return $outcode;
+}
+
+#=======================================================================
+#
+# _all_codes ( TYPE,CODESET )
+#
+#=======================================================================
+
+sub _all_codes {
+ my($type,$codeset) = @_;
+
+ if (! exists $Data{$type}{'code2id'}{$codeset}) {
+ return ();
+ }
+ my @codes = keys %{ $Data{$type}{'code2id'}{$codeset} };
+ return (sort @codes);
+}
+
+#=======================================================================
+#
+# _all_names ( TYPE,CODESET )
+#
+#=======================================================================
+
+sub _all_names {
+ my($type,$codeset) = @_;
+
+ my @codes = _all_codes($type,$codeset);
+ return () if (! @codes);
+ my @names;
+
+ foreach my $code (@codes) {
+ my($id,$i) = @{ $Data{$type}{'code2id'}{$codeset}{$code} };
+ my $name = $Data{$type}{'id2names'}{$id}[$i];
+ push(@names,$name);
+ }
+ return (sort @names);
+}
+
+#=======================================================================
+#
+# _rename ( TYPE,CODE,NAME,CODESET )
+#
+# Change the official name for a code. The original is retained
+# as an alias, but the new name will be returned if you lookup the
+# name from code.
+#
+#=======================================================================
+
+sub _rename {
+ my($type,$code,$new_name,$codeset,$nowarn) = @_;
+
+ if (! $codeset) {
+ carp "rename_$type(): unknown codeset\n" unless ($nowarn);
+ return 0;
+ }
+
+ $code = $Data{$type}{'codealias'}{$codeset}{$code}
+ if (exists $Data{$type}{'codealias'}{$codeset}{$code});
+
+ # Check that $code exists in the codeset.
+
+ my $id;
+ if (exists $Data{$type}{'code2id'}{$codeset}{$code}) {
+ $id = $Data{$type}{'code2id'}{$codeset}{$code}[0];
+ } else {
+ carp "rename_$type(): unknown code: $code\n" unless ($nowarn);
+ return 0;
+ }
+
+ # Cases:
+ # 1. Renaming to a name which exists with a different ID
+ # Error
+ #
+ # 2. Renaming to a name which exists with the same ID
+ # Just change code2id (I value)
+ #
+ # 3. Renaming to a new name
+ # Create a new alias
+ # Change code2id (I value)
+
+ if (exists $Data{$type}{'alias2id'}{lc($new_name)}) {
+ # Existing name (case 1 and 2)
+
+ my ($new_id,$i) = @{ $Data{$type}{'alias2id'}{lc($new_name)} };
+ if ($new_id != $id) {
+ # Case 1
+ carp "rename_$type(): rename to an existing $type not allowed\n"
+ unless ($nowarn);
+ return 0;
+ }
+
+ # Case 2
+
+ $Data{$type}{'code2id'}{$codeset}{$code}[1] = $i;
+
+ } else {
+
+ # Case 3
+
+ push @{ $Data{$type}{'id2names'}{$id} },$new_name;
+ my $i = $#{ $Data{$type}{'id2names'}{$id} };
+ $Data{$type}{'alias2id'}{lc($new_name)} = [ $id,$i ];
+ $Data{$type}{'code2id'}{$codeset}{$code}[1] = $i;
+ }
+
+ return 1;
+}
+
+#=======================================================================
+#
+# _add_code ( TYPE,CODE,NAME,CODESET )
+#
+# Add a new code to the codeset. Both CODE and NAME must be
+# unused in the code set.
+#
+#=======================================================================
+
+sub _add_code {
+ my($type,$code,$name,$codeset,$nowarn) = @_;
+
+ if (! $codeset) {
+ carp "add_$type(): unknown codeset\n" unless ($nowarn);
+ return 0;
+ }
+
+ # Check that $code is unused.
+
+ if (exists $Data{$type}{'code2id'}{$codeset}{$code} ||
+ exists $Data{$type}{'codealias'}{$codeset}{$code}) {
+ carp "add_$type(): code already in use: $code\n" unless ($nowarn);
+ return 0;
+ }
+
+ # Check to see that $name is unused in this code set. If it is
+ # used (but not in this code set), we'll use that ID. Otherwise,
+ # we'll need to get the next available ID.
+
+ my ($id,$i);
+ if (exists $Data{$type}{'alias2id'}{lc($name)}) {
+ ($id,$i) = @{ $Data{$type}{'alias2id'}{lc($name)} };
+ if (exists $Data{$type}{'id2code'}{$codeset}{$id}) {
+ carp "add_$type(): name already in use: $name\n" unless ($nowarn);
+ return 0;
+ }
+
+ } else {
+ $id = $Data{$type}{'id'}++;
+ $i = 0;
+ $Data{$type}{'alias2id'}{lc($name)} = [ $id,$i ];
+ $Data{$type}{'id2names'}{$id} = [ $name ];
+ }
+
+ # Add the new code
+
+ $Data{$type}{'code2id'}{$codeset}{$code} = [ $id,$i ];
+ $Data{$type}{'id2code'}{$codeset}{$id} = $code;
+
+ return 1;
+}
+
+#=======================================================================
+#
+# _delete_code ( TYPE,CODE,CODESET )
+#
+# Delete a code from the codeset.
+#
+#=======================================================================
+
+sub _delete_code {
+ my($type,$code,$codeset,$nowarn) = @_;
+
+ if (! $codeset) {
+ carp "delete_$type(): unknown codeset\n" unless ($nowarn);
+ return 0;
+ }
+
+ $code = $Data{$type}{'codealias'}{$codeset}{$code}
+ if (exists $Data{$type}{'codealias'}{$codeset}{$code});
+
+ # Check that $code is valid.
+
+ if (! exists $Data{$type}{'code2id'}{$codeset}{$code}) {
+ carp "delete_$type(): code does not exist: $code\n" unless ($nowarn);
+ return 0;
+ }
+
+ # Delete the code
+
+ my $id = $Data{$type}{'code2id'}{$codeset}{$code}[0];
+ delete $Data{$type}{'code2id'}{$codeset}{$code};
+ delete $Data{$type}{'id2code'}{$codeset}{$id};
+
+ # Delete any aliases that are linked to this code
+
+ foreach my $alias (keys %{ $Data{$type}{'codealias'}{$codeset} }) {
+ next if ($Data{$type}{'codealias'}{$codeset}{$alias} ne $code);
+ delete $Data{$type}{'codealias'}{$codeset}{$alias};
+ }
+
+ # If this ID is not used in any other codeset, delete it completely.
+
+ foreach my $c (keys %{ $Data{$type}{'id2code'} }) {
+ return 1 if (exists $Data{$type}{'id2code'}{$c}{$id});
+ }
+
+ my @names = @{ $Data{$type}{'id2names'}{$id} };
+ delete $Data{$type}{'id2names'}{$id};
+
+ foreach my $name (@names) {
+ delete $Data{$type}{'alias2id'}{lc($name)};
+ }
+
+ return 1;
+}
+
+#=======================================================================
+#
+# _add_alias ( TYPE,NAME,NEW_NAME )
+#
+# Add a new alias. NAME must exist, and NEW_NAME must be unused.
+#
+#=======================================================================
+
+sub _add_alias {
+ my($type,$name,$new_name,$nowarn) = @_;
+
+ # Check that $name is used and $new_name is new.
+
+ my($id);
+ if (exists $Data{$type}{'alias2id'}{lc($name)}) {
+ $id = $Data{$type}{'alias2id'}{lc($name)}[0];
+ } else {
+ carp "add_${type}_alias(): name does not exist: $name\n" unless ($nowarn);
+ return 0;
+ }
+
+ if (exists $Data{$type}{'alias2id'}{lc($new_name)}) {
+ carp "add_${type}_alias(): alias already in use: $new_name\n" unless ($nowarn);
+ return 0;
+ }
+
+ # Add the new alias
+
+ push @{ $Data{$type}{'id2names'}{$id} },$new_name;
+ my $i = $#{ $Data{$type}{'id2names'}{$id} };
+ $Data{$type}{'alias2id'}{lc($new_name)} = [ $id,$i ];
+
+ return 1;
+}
+
+#=======================================================================
+#
+# _delete_alias ( TYPE,NAME )
+#
+# This deletes a name from the list of names used by an element.
+# NAME must be used, but must NOT be the only name in the list.
+#
+# Any id2name that references this name will be changed to
+# refer to the first name in the list.
+#
+#=======================================================================
+
+sub _delete_alias {
+ my($type,$name,$nowarn) = @_;
+
+ # Check that $name is used.
+
+ my($id,$i);
+ if (exists $Data{$type}{'alias2id'}{lc($name)}) {
+ ($id,$i) = @{ $Data{$type}{'alias2id'}{lc($name)} };
+ } else {
+ carp "delete_${type}_alias(): name does not exist: $name\n" unless ($nowarn);
+ return 0;
+ }
+
+ my $n = $#{ $Data{$type}{'id2names'}{$id} };
+ if ($n == 1) {
+ carp "delete_${type}_alias(): only one name defined (use _delete_${type} instead)\n"
+ unless ($nowarn);
+ return 0;
+ }
+
+ # Delete the alias.
+
+ splice (@{ $Data{$type}{'id2names'}{$id} },$i,1);
+ delete $Data{$type}{'alias2id'}{lc($name)};
+
+ # Every element that refers to this ID:
+ # Ignore if I < $i
+ # Set to 0 if I = $i
+ # Decrement if I > $i
+
+ foreach my $codeset (keys %{ $Data{'code2id'} }) {
+ foreach my $code (keys %{ $Data{'code2id'}{$codeset} }) {
+ my($jd,$j) = @{ $Data{'code2id'}{$codeset}{$code} };
+ next if ($jd ne $id ||
+ $j < $i);
+ if ($i == $j) {
+ $Data{'code2id'}{$codeset}{$code}[1] = 0;
+ } else {
+ $Data{'code2id'}{$codeset}{$code}[1]--;
+ }
+ }
+ }
+
+ return 1;
+}
+
+#=======================================================================
+#
+# _rename_code ( TYPE,CODE,NEW_CODE,CODESET )
+#
+# Change the official code. The original is retained as an alias, but
+# the new name will be returned if you lookup the code from name.
+#
+#=======================================================================
+
+sub _rename_code {
+ my($type,$code,$new_code,$codeset,$nowarn) = @_;
+
+ if (! $codeset) {
+ carp "rename_$type(): unknown codeset\n" unless ($nowarn);
+ return 0;
+ }
+
+ $code = $Data{$type}{'codealias'}{$codeset}{$code}
+ if (exists $Data{$type}{'codealias'}{$codeset}{$code});
+
+ # Check that $code exists in the codeset.
+
+ if (! exists $Data{$type}{'code2id'}{$codeset}{$code}) {
+ carp "rename_$type(): unknown code: $code\n" unless ($nowarn);
+ return 0;
+ }
+
+ # Cases:
+ # 1. Renaming code to an existing alias of this code:
+ # Make the alias real and the code an alias
+ #
+ # 2. Renaming code to some other existing alias:
+ # Error
+ #
+ # 3. Renaming code to some other code:
+ # Error (
+ #
+ # 4. Renaming code to a new code:
+ # Make code into an alias
+ # Replace code with new_code.
+
+ if (exists $Data{$type}{'codealias'}{$codeset}{$new_code}) {
+ # Cases 1 and 2
+ if ($Data{$type}{'codealias'}{$codeset}{$new_code} eq $code) {
+ # Case 1
+
+ delete $Data{$type}{'codealias'}{$codeset}{$new_code};
+
+ } else {
+ # Case 2
+ carp "rename_$type(): new code already in use: $new_code\n" unless ($nowarn);
+ return 0;
+ }
+
+ } elsif (exists $Data{$type}{'code2id'}{$codeset}{$new_code}) {
+ # Case 3
+ carp "rename_$type(): new code already in use: $new_code\n" unless ($nowarn);
+ return 0;
+ }
+
+ # Cases 1 and 4
+
+ $Data{$type}{'codealias'}{$codeset}{$code} = $new_code;
+
+ my $id = $Data{$type}{'code2id'}{$codeset}{$code}[0];
+ $Data{$type}{'code2id'}{$codeset}{$new_code} = $Data{$type}{'code2id'}{$codeset}{$code};
+ delete $Data{$type}{'code2id'}{$codeset}{$code};
+
+ $Data{$type}{'id2code'}{$codeset}{$id} = $new_code;
+
+ return 1;
+}
+
+#=======================================================================
+#
+# _add_code_alias ( TYPE,CODE,NEW_CODE,CODESET )
+#
+# Adds an alias for the code.
+#
+#=======================================================================
+
+sub _add_code_alias {
+ my($type,$code,$new_code,$codeset,$nowarn) = @_;
+
+ if (! $codeset) {
+ carp "add_${type}_code_alias(): unknown codeset\n" unless ($nowarn);
+ return 0;
+ }
+
+ $code = $Data{$type}{'codealias'}{$codeset}{$code}
+ if (exists $Data{$type}{'codealias'}{$codeset}{$code});
+
+ # Check that $code exists in the codeset and that $new_code
+ # does not exist.
+
+ if (! exists $Data{$type}{'code2id'}{$codeset}{$code}) {
+ carp "add_${type}_code_alias(): unknown code: $code\n" unless ($nowarn);
+ return 0;
+ }
+
+ if (exists $Data{$type}{'code2id'}{$codeset}{$new_code} ||
+ exists $Data{$type}{'codealias'}{$codeset}{$new_code}) {
+ carp "add_${type}_code_alias(): code already in use: $new_code\n" unless ($nowarn);
+ return 0;
+ }
+
+ # Add the alias
+
+ $Data{$type}{'codealias'}{$codeset}{$new_code} = $code;
+
+ return 1;
+}
+
+#=======================================================================
+#
+# _delete_code_alias ( TYPE,CODE,CODESET )
+#
+# Deletes an alias for the code.
+#
+#=======================================================================
+
+sub _delete_code_alias {
+ my($type,$code,$codeset,$nowarn) = @_;
+
+ if (! $codeset) {
+ carp "delete_${type}_code_alias(): unknown codeset\n" unless ($nowarn);
+ return 0;
+ }
+
+ # Check that $code exists in the codeset as an alias.
+
+ if (! exists $Data{$type}{'codealias'}{$codeset}{$code}) {
+ carp "delete_${type}_code_alias(): no alias defined: $code\n" unless ($nowarn);
+ return 0;
+ }
+
+ # Delete the alias
+
+ delete $Data{$type}{'codealias'}{$codeset}{$code};
+
+ return 1;
+}
+
+#=======================================================================
+#
+# alias_code ( ALIAS => CODE [ , CODESET ] )
+#
+# Add an alias for an existing code. If the CODESET isn't specified,
+# then we use the default (currently the alpha-2 codeset).
+#
+# Locale::Country::alias_code('uk' => 'gb');
+#
+#=======================================================================
+
+# sub alias_code {
+# my $nowarn = 0;
+# $nowarn = 1, pop if ($_[$#_] eq "nowarn");
+# my $alias = shift;
+# my $code = shift;
+# my $codeset = @_ > 0 ? shift : LOCALE_CODE_DEFAULT;
+
+# return 0 if ($codeset !~ /^\d+$/);
+
+# if ($codeset == LOCALE_CODE_ALPHA_2) {
+# $codeset = "alpha2";
+# $alias = lc($alias);
+# } elsif ($codeset == LOCALE_CODE_ALPHA_3) {
+# $codeset = "alpha3";
+# $alias = lc($alias);
+# } elsif ($codeset == LOCALE_CODE_FIPS) {
+# $codeset = "fips";
+# $alias = uc($alias);
+# } elsif ($codeset == LOCALE_CODE_NUMERIC) {
+# $codeset = "num";
+# return undef if ($alias =~ /\D/);
+# $alias = sprintf("%.3d", $alias);
+# } else {
+# carp "rename_country(): unknown codeset\n" unless ($nowarn);
+# return 0;
+# }
+
+# # Check that $code exists in the codeset.
+
+# my ($id,$i);
+# if (exists $Data{$type}{'code2id'}{$codeset}{$code}) {
+# ($id,$i) = @{ $Data{$type}{'code2id'}{$codeset}{$code} };
+# } else {
+# carp "alias_code: attempt to alias \"$alias\" to unknown country code \"$code\"\n"
+# unless ($nowarn);
+# return 0;
+# }
+
+# # Cases:
+# # The alias already exists.
+# # Error
+# #
+# # It's new
+# # Create a new entry in Code2CountryID
+# # Replace the entiry in CountryID2Code
+# # Regenerate %Codes
+
+# if (exists $Data{$type}{'code2id'}{$codeset}{$alias}) {
+# carp "alias_code: attempt to alias \"$alias\" which is already in use\n"
+# unless ($nowarn);
+# return 0;
+# }
+
+# $Data{$type}{'code2id'}{$codeset}{$alias} = [ $id, $i ];
+# $Data{$type}{'id2names'}ID2Code{$codeset}{$id} = $alias;
+
+# my @codes = keys %{ $Data{$type}{'code2id'}{$codeset} };
+# $Locale::CountryCodes::Codes{$codeset} = [ sort @codes ];
+
+# return $alias;
+# }
+
+1;
+# Local Variables:
+# mode: cperl
+# indent-tabs-mode: nil
+# cperl-indent-level: 3
+# cperl-continued-statement-offset: 2
+# cperl-continued-brace-offset: 0
+# cperl-brace-offset: 0
+# cperl-brace-imaginary-offset: 0
+# cperl-label-offset: -2
+# End: