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

   1 package Locale::Country;
   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 require Exporter;
  13 use Carp;
  14 use Locale::Codes;
  15 use Locale::Constants;
  16 use Locale::Codes::Country;
  17
  18 #=======================================================================
  19 #       Public Global Variables
  20 #=======================================================================
  21
  22 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
  23
  24 $VERSION='3.12';
  25 @ISA       = qw(Exporter);
  26 @EXPORT    = qw(code2country
  27                 country2code
  28                 all_country_codes
  29                 all_country_names
  30                 country_code2code
  31                 LOCALE_CODE_ALPHA_2
  32                 LOCALE_CODE_ALPHA_3
  33                 LOCALE_CODE_NUMERIC
  34                 LOCALE_CODE_FIPS
  35                 LOCALE_CODE_DOM
  36                );
  37
  38 sub _code {
  39    my($code,$codeset) = @_;
  40    $code = ""  if (! $code);
  41
  42    $codeset = LOCALE_CODE_DEFAULT  if (! defined($codeset)  ||  $codeset eq "");
  43
  44    if ($codeset =~ /^\d+$/) {
  45       if      ($codeset ==  LOCALE_CODE_ALPHA_2) {
  46          $codeset = "alpha2";
  47       } elsif ($codeset ==  LOCALE_CODE_ALPHA_3) {
  48          $codeset = "alpha3";
  49       } elsif ($codeset ==  LOCALE_CODE_NUMERIC) {
  50          $codeset = "num";
  51       } elsif ($codeset ==  LOCALE_CODE_FIPS) {
  52          $codeset = "fips";
  53       } elsif ($codeset ==  LOCALE_CODE_DOM) {
  54          $codeset = "dom";
  55       } else {
  56          return (1);
  57       }
  58    }
  59
  60    if      ($codeset eq "alpha2"  ||
  61             $codeset eq "alpha3") {
  62       $code    = lc($code);
  63    } elsif ($codeset eq "num") {
  64       if (defined($code)  &&  $code ne "") {
  65          return (1)  unless ($code =~ /^\d+$/);
  66          $code    = sprintf("%.3d", $code);
  67       }
  68    } elsif ($codeset eq "fips"  ||
  69             $codeset eq "dom") {
  70       $code    = uc($code);
  71    } else {
  72       return (1);
  73    }
  74
  75    return (0,$code,$codeset);
  76 }
  77
  78 #=======================================================================
  79 #
  80 # code2country ( CODE [,CODESET] )
  81 #
  82 #=======================================================================
  83
  84 sub code2country {
  85    my($err,$code,$codeset) = _code(@_);
  86    return undef  if ($err  ||
  87                      ! defined $code);
  88
  89    return Locale::Codes::_code2name("country",$code,$codeset);
  90 }
  91
  92 #=======================================================================
  93 #
  94 # country2code ( COUNTRY [,CODESET] )
  95 #
  96 #=======================================================================
  97
  98 sub country2code {
  99    my($country,$codeset) = @_;
 100    my($err,$tmp);
 101    ($err,$tmp,$codeset) = _code("",$codeset);
 102    return undef  if ($err  ||
 103                      ! defined $country);
 104
 105    return Locale::Codes::_name2code("country",$country,$codeset);
 106 }
 107
 108 #=======================================================================
 109 #
 110 # country_code2code ( CODE,CODESET_IN,CODESET_OUT )
 111 #
 112 #=======================================================================
 113
 114 sub country_code2code {
 115    (@_ == 3) or croak "country_code2code() takes 3 arguments!";
 116    my($code,$inset,$outset) = @_;
 117    my($err,$tmp);
 118    ($err,$code,$inset) = _code($code,$inset);
 119    return undef  if ($err);
 120    ($err,$tmp,$outset) = _code("",$outset);
 121    return undef  if ($err);
 122
 123    return Locale::Codes::_code2code("country",$code,$inset,$outset);
 124 }
 125
 126 #=======================================================================
 127 #
 128 # all_country_codes ( [CODESET] )
 129 #
 130 #=======================================================================
 131
 132 sub all_country_codes {
 133    my($codeset) = @_;
 134    my($err,$tmp);
 135    ($err,$tmp,$codeset) = _code("",$codeset);
 136    return undef  if ($err);
 137
 138    return Locale::Codes::_all_codes("country",$codeset);
 139 }
 140
 141
 142 #=======================================================================
 143 #
 144 # all_country_names ( [CODESET] )
 145 #
 146 #=======================================================================
 147
 148 sub all_country_names {
 149    my($codeset) = @_;
 150    my($err,$tmp);
 151    ($err,$tmp,$codeset) = _code("",$codeset);
 152    return undef  if ($err);
 153
 154    return Locale::Codes::_all_names("country",$codeset);
 155 }
 156
 157 #=======================================================================
 158 #
 159 # rename_country ( CODE,NAME [,CODESET] )
 160 #
 161 #=======================================================================
 162
 163 sub rename_country {
 164    my($code,$new_name,@args) = @_;
 165    my $nowarn   = 0;
 166    $nowarn      = 1, pop(@args)  if ($args[$#args] eq "nowarn");
 167    my $codeset  = shift(@args);
 168    my $err;
 169    ($err,$code,$codeset) = _code($code,$codeset);
 170
 171    return Locale::Codes::_rename("country",$code,$new_name,$codeset,$nowarn);
 172 }
 173
 174 #=======================================================================
 175 #
 176 # add_country ( CODE,NAME [,CODESET] )
 177 #
 178 #=======================================================================
 179
 180 sub add_country {
 181    my($code,$name,@args) = @_;
 182    my $nowarn   = 0;
 183    $nowarn      = 1, pop(@args)  if ($args[$#args] eq "nowarn");
 184    my $codeset  = shift(@args);
 185    my $err;
 186    ($err,$code,$codeset) = _code($code,$codeset);
 187
 188    return Locale::Codes::_add_code("country",$code,$name,$codeset,$nowarn);
 189 }
 190
 191 #=======================================================================
 192 #
 193 # delete_country ( CODE [,CODESET] )
 194 #
 195 #=======================================================================
 196
 197 sub delete_country {
 198    my($code,@args) = @_;
 199    my $nowarn   = 0;
 200    $nowarn      = 1, pop(@args)  if ($args[$#args] eq "nowarn");
 201    my $codeset  = shift(@args);
 202    my $err;
 203    ($err,$code,$codeset) = _code($code,$codeset);
 204
 205    return Locale::Codes::_delete_code("country",$code,$codeset,$nowarn);
 206 }
 207
 208 #=======================================================================
 209 #
 210 # add_country_alias ( NAME,NEW_NAME )
 211 #
 212 #=======================================================================
 213
 214 sub add_country_alias {
 215    my($name,$new_name,$nowarn) = @_;
 216    $nowarn   = (defined($nowarn)  &&  $nowarn eq "nowarn" ? 1 : 0);
 217
 218    return Locale::Codes::_add_alias("country",$name,$new_name,$nowarn);
 219 }
 220
 221 #=======================================================================
 222 #
 223 # delete_country_alias ( NAME )
 224 #
 225 #=======================================================================
 226
 227 sub delete_country_alias {
 228    my($name,$nowarn) = @_;
 229    $nowarn   = (defined($nowarn)  &&  $nowarn eq "nowarn" ? 1 : 0);
 230
 231    return Locale::Codes::_delete_alias("country",$name,$nowarn);
 232 }
 233
 234 #=======================================================================
 235 #
 236 # rename_country_code ( CODE,NEW_CODE [,CODESET] )
 237 #
 238 #=======================================================================
 239
 240 sub rename_country_code {
 241    my($code,$new_code,@args) = @_;
 242    my $nowarn   = 0;
 243    $nowarn      = 1, pop(@args)  if ($args[$#args] eq "nowarn");
 244    my $codeset  = shift(@args);
 245    my $err;
 246    ($err,$code,$codeset)     = _code($code,$codeset);
 247    ($err,$new_code,$codeset) = _code($new_code,$codeset)  if (! $err);
 248
 249    return Locale::Codes::_rename_code("country",$code,$new_code,$codeset,$nowarn);
 250 }
 251
 252 #=======================================================================
 253 #
 254 # add_country_code_alias ( CODE,NEW_CODE [,CODESET] )
 255 #
 256 #=======================================================================
 257
 258 sub add_country_code_alias {
 259    my($code,$new_code,@args) = @_;
 260    my $nowarn   = 0;
 261    $nowarn      = 1, pop(@args)  if ($args[$#args] eq "nowarn");
 262    my $codeset  = shift(@args);
 263    my $err;
 264    ($err,$code,$codeset)     = _code($code,$codeset);
 265    ($err,$new_code,$codeset) = _code($new_code,$codeset)  if (! $err);
 266
 267    return Locale::Codes::_add_code_alias("country",$code,$new_code,$codeset,$nowarn);
 268 }
 269
 270 #=======================================================================
 271 #
 272 # delete_country_code_alias ( CODE [,CODESET] )
 273 #
 274 #=======================================================================
 275
 276 sub delete_country_code_alias {
 277    my($code,@args) = @_;
 278    my $nowarn   = 0;
 279    $nowarn      = 1, pop(@args)  if ($args[$#args] eq "nowarn");
 280    my $codeset  = shift(@args);
 281    my $err;
 282    ($err,$code,$codeset)     = _code($code,$codeset);
 283
 284    return Locale::Codes::_delete_code_alias("country",$code,$codeset,$nowarn);
 285 }
 286
 287 #=======================================================================
 288 #
 289 # Old function for backward compatibility
 290 #
 291 #=======================================================================
 292
 293 sub alias_code {
 294    my($alias,$code,@args) = @_;
 295    my $success = rename_country_code($code,$alias,@args);
 296    return 0  if (! $success);
 297    return $alias;
 298 }
 299
 300 1;
 301 # Local Variables:
 302 # mode: cperl
 303 # indent-tabs-mode: nil
 304 # cperl-indent-level: 3
 305 # cperl-continued-statement-offset: 2
 306 # cperl-continued-brace-offset: 0
 307 # cperl-brace-offset: 0
 308 # cperl-brace-imaginary-offset: 0
 309 # cperl-label-offset: -2
 310 # End: