cpan/Locale-Codes/lib/Locale/Codes.pm

   1 package Locale::Codes;
   2 # Copyright (C) 2001      Canon Research Centre Europe (CRE).
   3 # Copyright (C) 2002-2009 Neil Bowers
   4 # Copyright (c) 2010-2010 Sullivan Beck
   5 # This program is free software; you can redistribute it and/or modify it
   6 # under the same terms as Perl itself.
   7
   8 use strict;
   9 use warnings;
  10 require 5.002;
  11
  12 use Carp;
  13
  14 #=======================================================================
  15 #       Public Global Variables
  16 #=======================================================================
  17
  18 # This module is not called directly... %Data is filled in by the
  19 # calling modules.
  20
  21 use vars qw($VERSION %Data);
  22
  23 # $Data{ TYPE }{ code2id   }{ CODESET } { CODE }  = [ ID, I ]
  24 #              { id2code   }{ CODESET } { ID }    = CODE
  25 #              { id2names  }{ ID }                = [ NAME, NAME, ... ]
  26 #              { alias2id  }{ NAME }              = [ ID, I ]
  27 #              { id        }                      = FIRST_UNUSED_ID
  28 #              { codealias }{ CODESET } { ALIAS } = CODE
  29
  30 $VERSION='3.14';
  31
  32 #=======================================================================
  33 #
  34 # _code2name ( TYPE,CODE,CODESET )
  35 #
  36 #=======================================================================
  37
  38 sub _code2name {
  39    my($type,$code,$codeset) = @_;
  40
  41    $code = $Data{$type}{'codealias'}{$codeset}{$code}
  42      if (exists $Data{$type}{'codealias'}{$codeset}{$code});
  43
  44    if (exists $Data{$type}{'code2id'}{$codeset}  &&
  45        exists $Data{$type}{'code2id'}{$codeset}{$code}) {
  46       my ($id,$i) = @{ $Data{$type}{'code2id'}{$codeset}{$code} };
  47       my $name    = $Data{$type}{'id2names'}{$id}[$i];
  48       return $name;
  49    } else {
  50       #---------------------------------------------------------------
  51       # no such code!
  52       #---------------------------------------------------------------
  53       return undef;
  54    }
  55 }
  56
  57 #=======================================================================
  58 #
  59 # _name2code ( TYPE,NAME,CODESET )
  60 #
  61 #=======================================================================
  62
  63 sub _name2code {
  64    my($type,$name,$codeset) = @_;
  65    $name = ""  if (! $name);
  66    $name = lc($name);
  67
  68    if (exists $Data{$type}{'alias2id'}{$name}) {
  69       my $id = $Data{$type}{'alias2id'}{$name}[0];
  70       if (exists $Data{$type}{'id2code'}{$codeset}{$id}) {
  71          return $Data{$type}{'id2code'}{$codeset}{$id};
  72       }
  73    }
  74
  75    #---------------------------------------------------------------
  76    # no such name!
  77    #---------------------------------------------------------------
  78    return undef;
  79   }
  80
  81 #=======================================================================
  82 #
  83 # _code2code ( TYPE,CODE,CODESET )
  84 #
  85 #=======================================================================
  86
  87 sub _code2code {
  88    my($type,$code,$inset,$outset) = @_;
  89
  90    my $name    = _code2name($type,$code,$inset);
  91    my $outcode = _name2code($type,$name,$outset);
  92    return $outcode;
  93 }
  94
  95 #=======================================================================
  96 #
  97 # _all_codes ( TYPE,CODESET )
  98 #
  99 #=======================================================================
 100
 101 sub _all_codes {
 102    my($type,$codeset) = @_;
 103
 104    if (! exists $Data{$type}{'code2id'}{$codeset}) {
 105       return ();
 106    }
 107    my @codes = keys %{ $Data{$type}{'code2id'}{$codeset} };
 108    return (sort @codes);
 109 }
 110
 111 #=======================================================================
 112 #
 113 # _all_names ( TYPE,CODESET )
 114 #
 115 #=======================================================================
 116
 117 sub _all_names {
 118    my($type,$codeset) = @_;
 119
 120    my @codes = _all_codes($type,$codeset);
 121    return ()  if (! @codes);
 122    my @names;
 123
 124    foreach my $code (@codes) {
 125       my($id,$i) = @{ $Data{$type}{'code2id'}{$codeset}{$code} };
 126       my $name   = $Data{$type}{'id2names'}{$id}[$i];
 127       push(@names,$name);
 128    }
 129    return (sort @names);
 130 }
 131
 132 #=======================================================================
 133 #
 134 # _rename ( TYPE,CODE,NAME,CODESET )
 135 #
 136 # Change the official name for a code. The original is retained
 137 # as an alias, but the new name will be returned if you lookup the
 138 # name from code.
 139 #
 140 #=======================================================================
 141
 142 sub _rename {
 143    my($type,$code,$new_name,$codeset,$nowarn) = @_;
 144
 145    if (! $codeset) {
 146       carp "rename_$type(): unknown codeset\n"  unless ($nowarn);
 147       return 0;
 148    }
 149
 150    $code = $Data{$type}{'codealias'}{$codeset}{$code}
 151      if (exists $Data{$type}{'codealias'}{$codeset}{$code});
 152
 153    # Check that $code exists in the codeset.
 154
 155    my $id;
 156    if (exists $Data{$type}{'code2id'}{$codeset}{$code}) {
 157       $id = $Data{$type}{'code2id'}{$codeset}{$code}[0];
 158    } else {
 159       carp "rename_$type(): unknown code: $code\n"  unless ($nowarn);
 160       return 0;
 161    }
 162
 163    # Cases:
 164    #   1. Renaming to a name which exists with a different ID
 165    #      Error
 166    #
 167    #   2. Renaming to a name which exists with the same ID
 168    #      Just change code2id (I value)
 169    #
 170    #   3. Renaming to a new name
 171    #      Create a new alias
 172    #      Change code2id (I value)
 173
 174    if (exists $Data{$type}{'alias2id'}{lc($new_name)}) {
 175       # Existing name (case 1 and 2)
 176
 177       my ($new_id,$i) = @{ $Data{$type}{'alias2id'}{lc($new_name)} };
 178       if ($new_id != $id) {
 179          # Case 1
 180          carp "rename_$type(): rename to an existing $type not allowed\n"
 181            unless ($nowarn);
 182          return 0;
 183       }
 184
 185       # Case 2
 186
 187       $Data{$type}{'code2id'}{$codeset}{$code}[1] = $i;
 188
 189    } else {
 190
 191       # Case 3
 192
 193       push @{ $Data{$type}{'id2names'}{$id} },$new_name;
 194       my $i = $#{ $Data{$type}{'id2names'}{$id} };
 195       $Data{$type}{'alias2id'}{lc($new_name)} = [ $id,$i ];
 196       $Data{$type}{'code2id'}{$codeset}{$code}[1] = $i;
 197    }
 198
 199    return 1;
 200 }
 201
 202 #=======================================================================
 203 #
 204 # _add_code ( TYPE,CODE,NAME,CODESET )
 205 #
 206 # Add a new code to the codeset. Both CODE and NAME must be
 207 # unused in the code set.
 208 #
 209 #=======================================================================
 210
 211 sub _add_code {
 212    my($type,$code,$name,$codeset,$nowarn) = @_;
 213
 214    if (! $codeset) {
 215       carp "add_$type(): unknown codeset\n"  unless ($nowarn);
 216       return 0;
 217    }
 218
 219    # Check that $code is unused.
 220
 221    if (exists $Data{$type}{'code2id'}{$codeset}{$code}  ||
 222        exists $Data{$type}{'codealias'}{$codeset}{$code}) {
 223       carp "add_$type(): code already in use: $code\n"  unless ($nowarn);
 224       return 0;
 225    }
 226
 227    # Check to see that $name is unused in this code set.  If it is
 228    # used (but not in this code set), we'll use that ID.  Otherwise,
 229    # we'll need to get the next available ID.
 230
 231    my ($id,$i);
 232    if (exists $Data{$type}{'alias2id'}{lc($name)}) {
 233       ($id,$i) = @{ $Data{$type}{'alias2id'}{lc($name)} };
 234       if (exists $Data{$type}{'id2code'}{$codeset}{$id}) {
 235          carp "add_$type(): name already in use: $name\n"  unless ($nowarn);
 236          return 0;
 237       }
 238
 239    } else {
 240       $id = $Data{$type}{'id'}++;
 241       $i  = 0;
 242       $Data{$type}{'alias2id'}{lc($name)} = [ $id,$i ];
 243       $Data{$type}{'id2names'}{$id}       = [ $name ];
 244    }
 245
 246    # Add the new code
 247
 248    $Data{$type}{'code2id'}{$codeset}{$code} = [ $id,$i ];
 249    $Data{$type}{'id2code'}{$codeset}{$id}   = $code;
 250
 251    return 1;
 252 }
 253
 254 #=======================================================================
 255 #
 256 # _delete_code ( TYPE,CODE,CODESET )
 257 #
 258 # Delete a code from the codeset.
 259 #
 260 #=======================================================================
 261
 262 sub _delete_code {
 263    my($type,$code,$codeset,$nowarn) = @_;
 264
 265    if (! $codeset) {
 266       carp "delete_$type(): unknown codeset\n"  unless ($nowarn);
 267       return 0;
 268    }
 269
 270    $code = $Data{$type}{'codealias'}{$codeset}{$code}
 271      if (exists $Data{$type}{'codealias'}{$codeset}{$code});
 272
 273    # Check that $code is valid.
 274
 275    if (! exists $Data{$type}{'code2id'}{$codeset}{$code}) {
 276       carp "delete_$type(): code does not exist: $code\n"  unless ($nowarn);
 277       return 0;
 278    }
 279
 280    # Delete the code
 281
 282    my $id = $Data{$type}{'code2id'}{$codeset}{$code}[0];
 283    delete $Data{$type}{'code2id'}{$codeset}{$code};
 284    delete $Data{$type}{'id2code'}{$codeset}{$id};
 285
 286    # Delete any aliases that are linked to this code
 287
 288    foreach my $alias (keys %{ $Data{$type}{'codealias'}{$codeset} }) {
 289       next  if ($Data{$type}{'codealias'}{$codeset}{$alias} ne $code);
 290       delete $Data{$type}{'codealias'}{$codeset}{$alias};
 291    }
 292
 293    # If this ID is not used in any other codeset, delete it completely.
 294
 295    foreach my $c (keys %{ $Data{$type}{'id2code'} }) {
 296       return 1  if (exists $Data{$type}{'id2code'}{$c}{$id});
 297    }
 298
 299    my @names = @{ $Data{$type}{'id2names'}{$id} };
 300    delete $Data{$type}{'id2names'}{$id};
 301
 302    foreach my $name (@names) {
 303       delete $Data{$type}{'alias2id'}{lc($name)};
 304    }
 305
 306    return 1;
 307 }
 308
 309 #=======================================================================
 310 #
 311 # _add_alias ( TYPE,NAME,NEW_NAME )
 312 #
 313 # Add a new alias. NAME must exist, and NEW_NAME must be unused.
 314 #
 315 #=======================================================================
 316
 317 sub _add_alias {
 318    my($type,$name,$new_name,$nowarn) = @_;
 319
 320    # Check that $name is used and $new_name is new.
 321
 322    my($id);
 323    if (exists $Data{$type}{'alias2id'}{lc($name)}) {
 324       $id = $Data{$type}{'alias2id'}{lc($name)}[0];
 325    } else {
 326       carp "add_${type}_alias(): name does not exist: $name\n"  unless ($nowarn);
 327       return 0;
 328    }
 329
 330    if (exists $Data{$type}{'alias2id'}{lc($new_name)}) {
 331       carp "add_${type}_alias(): alias already in use: $new_name\n"  unless ($nowarn);
 332       return 0;
 333    }
 334
 335    # Add the new alias
 336
 337    push @{ $Data{$type}{'id2names'}{$id} },$new_name;
 338    my $i = $#{ $Data{$type}{'id2names'}{$id} };
 339    $Data{$type}{'alias2id'}{lc($new_name)} = [ $id,$i ];
 340
 341    return 1;
 342 }
 343
 344 #=======================================================================
 345 #
 346 # _delete_alias ( TYPE,NAME )
 347 #
 348 # This deletes a name from the list of names used by an element.
 349 # NAME must be used, but must NOT be the only name in the list.
 350 #
 351 # Any id2name that references this name will be changed to
 352 # refer to the first name in the list.
 353 #
 354 #=======================================================================
 355
 356 sub _delete_alias {
 357    my($type,$name,$nowarn) = @_;
 358
 359    # Check that $name is used.
 360
 361    my($id,$i);
 362    if (exists $Data{$type}{'alias2id'}{lc($name)}) {
 363       ($id,$i) = @{ $Data{$type}{'alias2id'}{lc($name)} };
 364    } else {
 365       carp "delete_${type}_alias(): name does not exist: $name\n"  unless ($nowarn);
 366       return 0;
 367    }
 368
 369    my $n = $#{ $Data{$type}{'id2names'}{$id} };
 370    if ($n == 1) {
 371       carp "delete_${type}_alias(): only one name defined (use _delete_${type} instead)\n"
 372         unless ($nowarn);
 373       return 0;
 374    }
 375
 376    # Delete the alias.
 377
 378    splice (@{ $Data{$type}{'id2names'}{$id} },$i,1);
 379    delete $Data{$type}{'alias2id'}{lc($name)};
 380
 381    # Every element that refers to this ID:
 382    #   Ignore     if I < $i
 383    #   Set to 0   if I = $i
 384    #   Decrement  if I > $i
 385
 386    foreach my $codeset (keys %{ $Data{'code2id'} }) {
 387       foreach my $code (keys %{ $Data{'code2id'}{$codeset} }) {
 388          my($jd,$j) = @{ $Data{'code2id'}{$codeset}{$code} };
 389          next  if ($jd ne $id  ||
 390                    $j < $i);
 391          if ($i == $j) {
 392             $Data{'code2id'}{$codeset}{$code}[1] = 0;
 393          } else {
 394             $Data{'code2id'}{$codeset}{$code}[1]--;
 395          }
 396       }
 397    }
 398
 399    return 1;
 400 }
 401
 402 #=======================================================================
 403 #
 404 # _rename_code ( TYPE,CODE,NEW_CODE,CODESET )
 405 #
 406 # Change the official code. The original is retained as an alias, but
 407 # the new name will be returned if you lookup the code from name.
 408 #
 409 #=======================================================================
 410
 411 sub _rename_code {
 412    my($type,$code,$new_code,$codeset,$nowarn) = @_;
 413
 414    if (! $codeset) {
 415       carp "rename_$type(): unknown codeset\n"  unless ($nowarn);
 416       return 0;
 417    }
 418
 419    $code = $Data{$type}{'codealias'}{$codeset}{$code}
 420      if (exists $Data{$type}{'codealias'}{$codeset}{$code});
 421
 422    # Check that $code exists in the codeset.
 423
 424    if (! exists $Data{$type}{'code2id'}{$codeset}{$code}) {
 425       carp "rename_$type(): unknown code: $code\n"  unless ($nowarn);
 426       return 0;
 427    }
 428
 429    # Cases:
 430    #   1. Renaming code to an existing alias of this code:
 431    #      Make the alias real and the code an alias
 432    #
 433    #   2. Renaming code to some other existing alias:
 434    #      Error
 435    #
 436    #   3. Renaming code to some other code:
 437    #      Error (
 438    #
 439    #   4. Renaming code to a new code:
 440    #      Make code into an alias
 441    #      Replace code with new_code.
 442
 443    if (exists $Data{$type}{'codealias'}{$codeset}{$new_code}) {
 444       # Cases 1 and 2
 445       if ($Data{$type}{'codealias'}{$codeset}{$new_code} eq $code) {
 446          # Case 1
 447
 448          delete $Data{$type}{'codealias'}{$codeset}{$new_code};
 449
 450       } else {
 451          # Case 2
 452          carp "rename_$type(): new code already in use: $new_code\n"  unless ($nowarn);
 453          return 0;
 454       }
 455
 456    } elsif (exists $Data{$type}{'code2id'}{$codeset}{$new_code}) {
 457       # Case 3
 458       carp "rename_$type(): new code already in use: $new_code\n"  unless ($nowarn);
 459       return 0;
 460    }
 461
 462    # Cases 1 and 4
 463
 464    $Data{$type}{'codealias'}{$codeset}{$code} = $new_code;
 465
 466    my $id = $Data{$type}{'code2id'}{$codeset}{$code}[0];
 467    $Data{$type}{'code2id'}{$codeset}{$new_code} = $Data{$type}{'code2id'}{$codeset}{$code};
 468    delete $Data{$type}{'code2id'}{$codeset}{$code};
 469
 470    $Data{$type}{'id2code'}{$codeset}{$id} = $new_code;
 471
 472    return 1;
 473 }
 474
 475 #=======================================================================
 476 #
 477 # _add_code_alias ( TYPE,CODE,NEW_CODE,CODESET )
 478 #
 479 # Adds an alias for the code.
 480 #
 481 #=======================================================================
 482
 483 sub _add_code_alias {
 484    my($type,$code,$new_code,$codeset,$nowarn) = @_;
 485
 486    if (! $codeset) {
 487       carp "add_${type}_code_alias(): unknown codeset\n"  unless ($nowarn);
 488       return 0;
 489    }
 490
 491    $code = $Data{$type}{'codealias'}{$codeset}{$code}
 492      if (exists $Data{$type}{'codealias'}{$codeset}{$code});
 493
 494    # Check that $code exists in the codeset and that $new_code
 495    # does not exist.
 496
 497    if (! exists $Data{$type}{'code2id'}{$codeset}{$code}) {
 498       carp "add_${type}_code_alias(): unknown code: $code\n"  unless ($nowarn);
 499       return 0;
 500    }
 501
 502    if (exists $Data{$type}{'code2id'}{$codeset}{$new_code}  ||
 503        exists $Data{$type}{'codealias'}{$codeset}{$new_code}) {
 504       carp "add_${type}_code_alias(): code already in use: $new_code\n"  unless ($nowarn);
 505       return 0;
 506    }
 507
 508    # Add the alias
 509
 510    $Data{$type}{'codealias'}{$codeset}{$new_code} = $code;
 511
 512    return 1;
 513 }
 514
 515 #=======================================================================
 516 #
 517 # _delete_code_alias ( TYPE,CODE,CODESET )
 518 #
 519 # Deletes an alias for the code.
 520 #
 521 #=======================================================================
 522
 523 sub _delete_code_alias {
 524    my($type,$code,$codeset,$nowarn) = @_;
 525
 526    if (! $codeset) {
 527       carp "delete_${type}_code_alias(): unknown codeset\n"  unless ($nowarn);
 528       return 0;
 529    }
 530
 531    # Check that $code exists in the codeset as an alias.
 532
 533    if (! exists $Data{$type}{'codealias'}{$codeset}{$code}) {
 534       carp "delete_${type}_code_alias(): no alias defined: $code\n"  unless ($nowarn);
 535       return 0;
 536    }
 537
 538    # Delete the alias
 539
 540    delete $Data{$type}{'codealias'}{$codeset}{$code};
 541
 542    return 1;
 543 }
 544
 545 #=======================================================================
 546 #
 547 # alias_code ( ALIAS => CODE [ , CODESET ] )
 548 #
 549 # Add an alias for an existing code. If the CODESET isn't specified,
 550 # then we use the default (currently the alpha-2 codeset).
 551 #
 552 #   Locale::Country::alias_code('uk' => 'gb');
 553 #
 554 #=======================================================================
 555
 556 # sub alias_code {
 557 #    my $nowarn   = 0;
 558 #    $nowarn      = 1, pop  if ($_[$#_] eq "nowarn");
 559 #    my $alias    = shift;
 560 #    my $code     = shift;
 561 #    my $codeset  = @_ > 0 ? shift : LOCALE_CODE_DEFAULT;
 562
 563 #    return 0  if ($codeset !~ /^\d+$/);
 564
 565 #    if      ($codeset == LOCALE_CODE_ALPHA_2) {
 566 #       $codeset = "alpha2";
 567 #       $alias   = lc($alias);
 568 #    } elsif ($codeset == LOCALE_CODE_ALPHA_3) {
 569 #       $codeset = "alpha3";
 570 #       $alias   = lc($alias);
 571 #    } elsif ($codeset == LOCALE_CODE_FIPS) {
 572 #       $codeset = "fips";
 573 #       $alias   = uc($alias);
 574 #    } elsif ($codeset == LOCALE_CODE_NUMERIC) {
 575 #       $codeset = "num";
 576 #       return undef if ($alias =~ /\D/);
 577 #       $alias   = sprintf("%.3d", $alias);
 578 #    } else {
 579 #       carp "rename_country(): unknown codeset\n"  unless ($nowarn);
 580 #       return 0;
 581 #    }
 582
 583 #    # Check that $code exists in the codeset.
 584
 585 #    my ($id,$i);
 586 #    if (exists $Data{$type}{'code2id'}{$codeset}{$code}) {
 587 #       ($id,$i) = @{ $Data{$type}{'code2id'}{$codeset}{$code} };
 588 #    } else {
 589 #       carp "alias_code: attempt to alias \"$alias\" to unknown country code \"$code\"\n"
 590 #       unless ($nowarn);
 591 #       return 0;
 592 #    }
 593
 594 #    # Cases:
 595 #    #   The alias already exists.
 596 #    #      Error
 597 #    #
 598 #    #   It's new
 599 #    #      Create a new entry in Code2CountryID
 600 #    #      Replace the entiry in CountryID2Code
 601 #    #      Regenerate %Codes
 602
 603 #    if (exists $Data{$type}{'code2id'}{$codeset}{$alias}) {
 604 #       carp "alias_code: attempt to alias \"$alias\" which is already in use\n"
 605 #       unless ($nowarn);
 606 #       return 0;
 607 #    }
 608
 609 #    $Data{$type}{'code2id'}{$codeset}{$alias} = [ $id, $i ];
 610 #    $Data{$type}{'id2names'}ID2Code{$codeset}{$id} = $alias;
 611
 612 #    my @codes = keys %{ $Data{$type}{'code2id'}{$codeset} };
 613 #    $Locale::CountryCodes::Codes{$codeset} = [ sort @codes ];
 614
 615 #    return $alias;
 616 # }
 617
 618 1;
 619 # Local Variables:
 620 # mode: cperl
 621 # indent-tabs-mode: nil
 622 # cperl-indent-level: 3
 623 # cperl-continued-statement-offset: 2
 624 # cperl-continued-brace-offset: 0
 625 # cperl-brace-offset: 0
 626 # cperl-brace-imaginary-offset: 0
 627 # cperl-label-offset: -2
 628 # End: