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.pm239
1 files changed, 172 insertions, 67 deletions
diff --git a/Master/tlpkg/tlperl/lib/Locale/Codes.pm b/Master/tlpkg/tlperl/lib/Locale/Codes.pm
index 118c277c5b4..bbe6ab50dd5 100644
--- a/Master/tlpkg/tlperl/lib/Locale/Codes.pm
+++ b/Master/tlpkg/tlperl/lib/Locale/Codes.pm
@@ -1,7 +1,7 @@
package Locale::Codes;
# Copyright (C) 2001 Canon Research Centre Europe (CRE).
# Copyright (C) 2002-2009 Neil Bowers
-# Copyright (c) 2010-2015 Sullivan Beck
+# Copyright (c) 2010-2016 Sullivan Beck
# This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.
@@ -31,7 +31,7 @@ our($VERSION,%Data,%Retired);
# $Retired{ TYPE }{ CODESET }{ code }{ CODE } = NAME
# { name }{ NAME } = [CODE,NAME] (the key is lowercase)
-$VERSION='3.37';
+$VERSION='3.42';
#=======================================================================
#
@@ -40,7 +40,7 @@ $VERSION='3.37';
#=======================================================================
sub _code {
- return 1 if (@_ > 3);
+ return (1) if (@_ > 3);
my($type,$code,$codeset) = @_;
$code = '' if (! defined $code);
@@ -51,7 +51,7 @@ sub _code {
if (! defined($codeset) || $codeset eq '');
$codeset = lc($codeset);
return (1) if (! exists $ALL_CODESETS{$type}{'codesets'}{$codeset});
- return (0,$code,$codeset) if (! $code);
+ return (0,$code,$codeset) if ($code eq '');
# Determine the properties of the codeset
@@ -104,8 +104,7 @@ sub _code2name {
$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}) {
+ if (exists $Data{$type}{'code2id'}{$codeset}{$code}) {
my ($id,$i) = @{ $Data{$type}{'code2id'}{$codeset}{$code} };
my $name = $Data{$type}{'id2names'}{$id}[$i];
return $name;
@@ -130,7 +129,7 @@ sub _name2code {
$name = lc($name);
my $retired = 0;
- if (@args > 0 && $args[$#args] && $args[$#args] eq 'retired') {
+ if (@args > 0 && $args[$#args] eq 'retired') {
pop(@args);
$retired = 1;
}
@@ -159,7 +158,22 @@ sub _name2code {
sub _code2code {
my($type,@args) = @_;
- (@args == 3) or croak "${type}_code2code() takes 3 arguments!";
+
+ # For tests, we'll ALWAYS have $nowarn
+ my $nowarn = 0;
+ if (@args) { # uncoverable branch false
+ if ($args[$#args] eq "nowarn") { # uncoverable branch false
+ $nowarn = 1;
+ pop(@args);
+ }
+ }
+
+ if (@args != 3) {
+ if (! $nowarn) { # uncoverable branch true
+ croak "${type}_code2code() takes 3 arguments!"; # uncoverable statement
+ }
+ return undef;
+ }
my($code,$inset,$outset) = @args;
my($err,$tmp);
@@ -182,7 +196,7 @@ sub _code2code {
sub _all_codes {
my($type,@args) = @_;
my $retired = 0;
- if (@args > 0 && $args[$#args] && $args[$#args] eq 'retired') {
+ if (@args > 0 && $args[$#args] eq 'retired') {
pop(@args);
$retired = 1;
}
@@ -190,9 +204,6 @@ sub _all_codes {
my ($err,$tmp,$codeset) = _code($type,'',@args);
return () if ($err);
- if (! exists $Data{$type}{'code2id'}{$codeset}) {
- return ();
- }
my @codes = keys %{ $Data{$type}{'code2id'}{$codeset} };
push(@codes,keys %{ $Retired{$type}{$codeset}{'code'} }) if ($retired);
return (sort @codes);
@@ -207,7 +218,7 @@ sub _all_codes {
sub _all_names {
my($type,@args) = @_;
my $retired = 0;
- if (@args > 0 && $args[$#args] && $args[$#args] eq 'retired') {
+ if (@args > 0 && $args[$#args] eq 'retired') {
pop(@args);
$retired = 1;
}
@@ -245,28 +256,35 @@ sub _all_names {
sub _rename {
my($type,$code,$new_name,@args) = @_;
+ # For tests, we'll ALWAYS have $nowarn
my $nowarn = 0;
- $nowarn = 1, pop(@args) if (@args && $args[$#args] eq "nowarn");
+ if (@args) { # uncoverable branch false
+ if ($args[$#args] eq "nowarn") { # uncoverable branch false
+ $nowarn = 1;
+ pop(@args);
+ }
+ }
my $codeset = shift(@args);
my $err;
($err,$code,$codeset) = _code($type,$code,$codeset);
if (! $codeset) {
- carp "rename_$type(): unknown codeset\n" unless ($nowarn);
+ if (! $nowarn) { # uncoverable branch true
+ carp "rename_$type(): unknown codeset\n"; # uncoverable statement
+ }
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);
+ if (! $nowarn) { # uncoverable branch true
+ carp "rename_$type(): unknown code: $code\n"; # uncoverable statement
+ }
return 0;
}
@@ -287,8 +305,11 @@ sub _rename {
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);
+ if (! $nowarn) { # uncoverable branch true
+ # uncoverable statement
+ carp "rename_$type(): rename to an existing $type not allowed\n";
+ }
+
return 0;
}
@@ -321,15 +342,23 @@ sub _rename {
sub _add_code {
my($type,$code,$name,@args) = @_;
+ # For tests, we'll ALWAYS have $nowarn
my $nowarn = 0;
- $nowarn = 1, pop(@args) if (@args && $args[$#args] eq "nowarn");
+ if (@args) { # uncoverable branch false
+ if ($args[$#args] eq "nowarn") { # uncoverable branch false
+ $nowarn = 1;
+ pop(@args);
+ }
+ }
my $codeset = shift(@args);
my $err;
($err,$code,$codeset) = _code($type,$code,$codeset);
if (! $codeset) {
- carp "add_$type(): unknown codeset\n" unless ($nowarn);
+ if (! $nowarn) { # uncoverable branch true
+ carp "add_$type(): unknown codeset\n"; # uncoverable statement
+ }
return 0;
}
@@ -337,7 +366,9 @@ sub _add_code {
if (exists $Data{$type}{'code2id'}{$codeset}{$code} ||
exists $Data{$type}{'codealias'}{$codeset}{$code}) {
- carp "add_$type(): code already in use: $code\n" unless ($nowarn);
+ if (! $nowarn) { # uncoverable branch true
+ carp "add_$type(): code already in use: $code\n";# uncoverable statement
+ }
return 0;
}
@@ -349,7 +380,10 @@ sub _add_code {
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);
+ if (! $nowarn) { # uncoverable branch true
+ # uncoverable statement
+ carp "add_$type(): name already in use: $name\n";
+ }
return 0;
}
@@ -379,25 +413,33 @@ sub _add_code {
sub _delete_code {
my($type,$code,@args) = @_;
+ # For tests, we'll ALWAYS have $nowarn
my $nowarn = 0;
- $nowarn = 1, pop(@args) if (@args && $args[$#args] eq "nowarn");
+ if (@args) { # uncoverable branch false
+ if ($args[$#args] eq "nowarn") { # uncoverable branch false
+ $nowarn = 1;
+ pop(@args);
+ }
+ }
my $codeset = shift(@args);
my $err;
($err,$code,$codeset) = _code($type,$code,$codeset);
if (! $codeset) {
- carp "delete_$type(): unknown codeset\n" unless ($nowarn);
+ if (! $nowarn) { # uncoverable branch true
+ carp "delete_$type(): unknown codeset\n"; # uncoverable statement
+ }
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);
+ if (! $nowarn) { # uncoverable branch true
+ # uncoverable statement
+ carp "delete_$type(): code does not exist: $code\n";
+ }
return 0;
}
@@ -439,9 +481,16 @@ sub _delete_code {
#=======================================================================
sub _add_alias {
- my($type,$name,$new_name,$nowarn) = @_;
+ my($type,$name,$new_name,@args) = @_;
- $nowarn = (defined($nowarn) && $nowarn eq "nowarn" ? 1 : 0);
+ # For tests, we'll ALWAYS have $nowarn
+ my $nowarn = 0;
+ if (@args) { # uncoverable branch false
+ if ($args[$#args] eq "nowarn") { # uncoverable branch false
+ $nowarn = 1;
+ pop(@args);
+ }
+ }
# Check that $name is used and $new_name is new.
@@ -449,12 +498,18 @@ sub _add_alias {
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);
+ if (! $nowarn) { # uncoverable branch true
+ # uncoverable statement
+ carp "add_${type}_alias(): name does not exist: $name\n";
+ }
return 0;
}
if (exists $Data{$type}{'alias2id'}{lc($new_name)}) {
- carp "add_${type}_alias(): alias already in use: $new_name\n" unless ($nowarn);
+ if (! $nowarn) { # uncoverable branch true
+ # uncoverable statement
+ carp "add_${type}_alias(): alias already in use: $new_name\n";
+ }
return 0;
}
@@ -480,9 +535,16 @@ sub _add_alias {
#=======================================================================
sub _delete_alias {
- my($type,$name,$nowarn) = @_;
+ my($type,$name,@args) = @_;
- $nowarn = (defined($nowarn) && $nowarn eq "nowarn" ? 1 : 0);
+ # For tests, we'll ALWAYS have $nowarn
+ my $nowarn = 0;
+ if (@args) { # uncoverable branch false
+ if ($args[$#args] eq "nowarn") { # uncoverable branch false
+ $nowarn = 1;
+ pop(@args);
+ }
+ }
# Check that $name is used.
@@ -490,14 +552,19 @@ sub _delete_alias {
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);
+ if (! $nowarn) { # uncoverable branch true
+ # uncoverable statement
+ carp "delete_${type}_alias(): name does not exist: $name\n";
+ }
return 0;
}
my $n = $#{ $Data{$type}{'id2names'}{$id} } + 1;
if ($n == 1) {
- carp "delete_${type}_alias(): only one name defined (use _delete_${type} instead)\n"
- unless ($nowarn);
+ if (! $nowarn) { # uncoverable branch true
+ # uncoverable statement
+ carp "delete_${type}_alias(): only one name defined (use _delete_${type} instead)\n";
+ }
return 0;
}
@@ -511,15 +578,15 @@ sub _delete_alias {
# 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} };
+ foreach my $codeset (keys %{ $Data{$type}{'code2id'} }) {
+ foreach my $code (keys %{ $Data{$type}{'code2id'}{$codeset} }) {
+ my($jd,$j) = @{ $Data{$type}{'code2id'}{$codeset}{$code} };
next if ($jd ne $id ||
$j < $i);
if ($i == $j) {
- $Data{'code2id'}{$codeset}{$code}[1] = 0;
+ $Data{$type}{'code2id'}{$codeset}{$code}[1] = 0;
} else {
- $Data{'code2id'}{$codeset}{$code}[1]--;
+ $Data{$type}{'code2id'}{$codeset}{$code}[1]--;
}
}
}
@@ -539,27 +606,35 @@ sub _delete_alias {
sub _rename_code {
my($type,$code,$new_code,@args) = @_;
+ # For tests, we'll ALWAYS have $nowarn
my $nowarn = 0;
- $nowarn = 1, pop(@args) if (@args && $args[$#args] eq "nowarn");
+ if (@args) { # uncoverable branch false
+ if ($args[$#args] eq "nowarn") { # uncoverable branch false
+ $nowarn = 1;
+ pop(@args);
+ }
+ }
my $codeset = shift(@args);
my $err;
($err,$code,$codeset) = _code($type,$code,$codeset);
- ($err,$new_code,$codeset) = _code($type,$new_code,$codeset)
- if (! $err);
if (! $codeset) {
- carp "rename_$type(): unknown codeset\n" unless ($nowarn);
+ if (! $nowarn) { # uncoverable branch true
+ carp "rename_${type}_code(): unknown codeset\n"; # uncoverable statement
+ }
return 0;
}
- $code = $Data{$type}{'codealias'}{$codeset}{$code}
- if (exists $Data{$type}{'codealias'}{$codeset}{$code});
+ ($err,$new_code,$codeset) = _code($type,$new_code,$codeset);
# Check that $code exists in the codeset.
if (! exists $Data{$type}{'code2id'}{$codeset}{$code}) {
- carp "rename_$type(): unknown code: $code\n" unless ($nowarn);
+ if (! $nowarn) { # uncoverable branch true
+ # uncoverable statement
+ carp "rename_${type}_code(): unknown code: $code\n";
+ }
return 0;
}
@@ -586,13 +661,19 @@ sub _rename_code {
} else {
# Case 2
- carp "rename_$type(): new code already in use: $new_code\n" unless ($nowarn);
+ if (! $nowarn) { # uncoverable branch true
+ # uncoverable statement
+ carp "rename_${type}_code(): new code already in use: $new_code\n";
+ }
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);
+ if (! $nowarn) { # uncoverable branch true
+ # uncoverable statement
+ carp "rename_${type}_code(): new code already in use: $new_code\n";
+ }
return 0;
}
@@ -620,34 +701,46 @@ sub _rename_code {
sub _add_code_alias {
my($type,$code,$new_code,@args) = @_;
+ # For tests, we'll ALWAYS have $nowarn
my $nowarn = 0;
- $nowarn = 1, pop(@args) if (@args && $args[$#args] eq "nowarn");
+ if (@args) { # uncoverable branch false
+ if ($args[$#args] eq "nowarn") { # uncoverable branch false
+ $nowarn = 1;
+ pop(@args);
+ }
+ }
my $codeset = shift(@args);
my $err;
($err,$code,$codeset) = _code($type,$code,$codeset);
- ($err,$new_code,$codeset) = _code($type,$new_code,$codeset)
- if (! $err);
if (! $codeset) {
- carp "add_${type}_code_alias(): unknown codeset\n" unless ($nowarn);
+ if (! $nowarn) { # uncoverable branch true
+ # uncoverable statement
+ carp "add_${type}_code_alias(): unknown codeset\n";
+ }
return 0;
}
- $code = $Data{$type}{'codealias'}{$codeset}{$code}
- if (exists $Data{$type}{'codealias'}{$codeset}{$code});
+ ($err,$new_code,$codeset) = _code($type,$new_code,$codeset);
# 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);
+ if (! $nowarn) { # uncoverable branch true
+ # uncoverable statement
+ carp "add_${type}_code_alias(): unknown code: $code\n";
+ }
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);
+ if (! $nowarn) { # uncoverable branch true
+ # uncoverable statement
+ carp "add_${type}_code_alias(): code already in use: $new_code\n";
+ }
return 0;
}
@@ -660,7 +753,7 @@ sub _add_code_alias {
#=======================================================================
#
-# _delete_code_alias ( TYPE,CODE,CODESET )
+# _delete_code_alias ( TYPE,ALIAS,CODESET )
#
# Deletes an alias for the code.
#
@@ -669,22 +762,34 @@ sub _add_code_alias {
sub _delete_code_alias {
my($type,$code,@args) = @_;
+ # For tests, we'll ALWAYS have $nowarn
my $nowarn = 0;
- $nowarn = 1, pop(@args) if (@args && $args[$#args] eq "nowarn");
+ if (@args) { # uncoverable branch false
+ if ($args[$#args] eq "nowarn") { # uncoverable branch false
+ $nowarn = 1;
+ pop(@args);
+ }
+ }
my $codeset = shift(@args);
my $err;
($err,$code,$codeset) = Locale::Codes::_code($type,$code,$codeset);
if (! $codeset) {
- carp "delete_${type}_code_alias(): unknown codeset\n" unless ($nowarn);
+ if (! $nowarn) { # uncoverable branch true
+ # uncoverable statement
+ carp "delete_${type}_code_alias(): unknown codeset\n";
+ }
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);
+ if (! $nowarn) { # uncoverable branch true
+ # uncoverable statement
+ carp "delete_${type}_code_alias(): no alias defined: $code\n";
+ }
return 0;
}
@@ -704,5 +809,5 @@ sub _delete_code_alias {
# cperl-continued-brace-offset: 0
# cperl-brace-offset: 0
# cperl-brace-imaginary-offset: 0
-# cperl-label-offset: -2
+# cperl-label-offset: 0
# End: