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

   1 package Locale::Script;
   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::Script;
  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(code2script
  27                 script2code
  28                 all_script_codes
  29                 all_script_names
  30                 script_code2code
  31                 LOCALE_SCRIPT_ALPHA
  32                 LOCALE_SCRIPT_NUMERIC
  33                );
  34
  35 sub _code {
  36    my($code,$codeset) = @_;
  37    $code = ""  if (! $code);
  38
  39    $codeset = LOCALE_SCRIPT_DEFAULT  if (! defined($codeset)  ||  $codeset eq "");
  40
  41    if ($codeset =~ /^\d+$/) {
  42       if      ($codeset ==  LOCALE_SCRIPT_ALPHA) {
  43          $codeset = "alpha";
  44       } elsif ($codeset ==  LOCALE_SCRIPT_NUMERIC) {
  45          $codeset = "num";
  46       } else {
  47          return (1);
  48       }
  49    }
  50
  51    if      ($codeset eq "alpha") {
  52       $code    = ucfirst(lc($code));
  53    } elsif ($codeset eq "num") {
  54       if (defined($code)  &&  $code ne "") {
  55          return (1)  unless ($code =~ /^\d+$/);
  56          $code    = sprintf("%.3d", $code);
  57       }
  58    } else {
  59       return (1);
  60    }
  61
  62    return (0,$code,$codeset);
  63 }
  64
  65 #=======================================================================
  66 #
  67 # code2script ( CODE [,CODESET] )
  68 #
  69 #=======================================================================
  70
  71 sub code2script {
  72    my($err,$code,$codeset) = _code(@_);
  73    return undef  if ($err  ||
  74                      ! defined $code);
  75
  76    return Locale::Codes::_code2name("script",$code,$codeset);
  77 }
  78
  79 #=======================================================================
  80 #
  81 # script2code ( SCRIPT [,CODESET] )
  82 #
  83 #=======================================================================
  84
  85 sub script2code {
  86    my($script,$codeset) = @_;
  87    my($err,$tmp);
  88    ($err,$tmp,$codeset) = _code("",$codeset);
  89    return undef  if ($err  ||
  90                      ! defined $script);
  91
  92    return Locale::Codes::_name2code("script",$script,$codeset);
  93 }
  94
  95 #=======================================================================
  96 #
  97 # script_code2code ( CODE,CODESET_IN,CODESET_OUT )
  98 #
  99 #=======================================================================
 100
 101 sub script_code2code {
 102    (@_ == 3) or croak "script_code2code() takes 3 arguments!";
 103    my($code,$inset,$outset) = @_;
 104    my($err,$tmp);
 105    ($err,$code,$inset) = _code($code,$inset);
 106    return undef  if ($err);
 107    ($err,$tmp,$outset) = _code("",$outset);
 108    return undef  if ($err);
 109
 110    return Locale::Codes::_code2code("script",$code,$inset,$outset);
 111 }
 112
 113 #=======================================================================
 114 #
 115 # all_script_codes ( [CODESET] )
 116 #
 117 #=======================================================================
 118
 119 sub all_script_codes {
 120    my($codeset) = @_;
 121    my($err,$tmp);
 122    ($err,$tmp,$codeset) = _code("",$codeset);
 123    return undef  if ($err);
 124
 125    return Locale::Codes::_all_codes("script",$codeset);
 126 }
 127
 128
 129 #=======================================================================
 130 #
 131 # all_script_names ( [CODESET] )
 132 #
 133 #=======================================================================
 134
 135 sub all_script_names {
 136    my($codeset) = @_;
 137    my($err,$tmp);
 138    ($err,$tmp,$codeset) = _code("",$codeset);
 139    return undef  if ($err);
 140
 141    return Locale::Codes::_all_names("script",$codeset);
 142 }
 143
 144 #=======================================================================
 145 #
 146 # rename_script ( CODE,NAME [,CODESET] )
 147 #
 148 #=======================================================================
 149
 150 sub rename_script {
 151    my($code,$new_name,@args) = @_;
 152    my $nowarn   = 0;
 153    $nowarn      = 1, pop(@args)  if ($args[$#args] eq "nowarn");
 154    my $codeset  = shift(@args);
 155    my $err;
 156    ($err,$code,$codeset) = _code($code,$codeset);
 157
 158    return Locale::Codes::_rename("script",$code,$new_name,$codeset,$nowarn);
 159 }
 160
 161 #=======================================================================
 162 #
 163 # add_script ( CODE,NAME [,CODESET] )
 164 #
 165 #=======================================================================
 166
 167 sub add_script {
 168    my($code,$name,@args) = @_;
 169    my $nowarn   = 0;
 170    $nowarn      = 1, pop(@args)  if ($args[$#args] eq "nowarn");
 171    my $codeset  = shift(@args);
 172    my $err;
 173    ($err,$code,$codeset) = _code($code,$codeset);
 174
 175    return Locale::Codes::_add_code("script",$code,$name,$codeset,$nowarn);
 176 }
 177
 178 #=======================================================================
 179 #
 180 # delete_script ( CODE [,CODESET] )
 181 #
 182 #=======================================================================
 183
 184 sub delete_script {
 185    my($code,@args) = @_;
 186    my $nowarn   = 0;
 187    $nowarn      = 1, pop(@args)  if ($args[$#args] eq "nowarn");
 188    my $codeset  = shift(@args);
 189    my $err;
 190    ($err,$code,$codeset) = _code($code,$codeset);
 191
 192    return Locale::Codes::_delete_code("script",$code,$codeset,$nowarn);
 193 }
 194
 195 #=======================================================================
 196 #
 197 # add_script_alias ( NAME,NEW_NAME )
 198 #
 199 #=======================================================================
 200
 201 sub add_script_alias {
 202    my($name,$new_name,$nowarn) = @_;
 203    $nowarn   = (defined($nowarn)  &&  $nowarn eq "nowarn" ? 1 : 0);
 204
 205    return Locale::Codes::_add_alias("script",$name,$new_name,$nowarn);
 206 }
 207
 208 #=======================================================================
 209 #
 210 # delete_script_alias ( NAME )
 211 #
 212 #=======================================================================
 213
 214 sub delete_script_alias {
 215    my($name,$nowarn) = @_;
 216    $nowarn   = (defined($nowarn)  &&  $nowarn eq "nowarn" ? 1 : 0);
 217
 218    return Locale::Codes::_delete_alias("script",$name,$nowarn);
 219 }
 220
 221 #=======================================================================
 222 #
 223 # rename_script_code ( CODE,NEW_CODE [,CODESET] )
 224 #
 225 #=======================================================================
 226
 227 sub rename_script_code {
 228    my($code,$new_code,@args) = @_;
 229    my $nowarn   = 0;
 230    $nowarn      = 1, pop(@args)  if ($args[$#args] eq "nowarn");
 231    my $codeset  = shift(@args);
 232    my $err;
 233    ($err,$code,$codeset)     = _code($code,$codeset);
 234    ($err,$new_code,$codeset) = _code($new_code,$codeset)  if (! $err);
 235
 236    return Locale::Codes::_rename_code("script",$code,$new_code,$codeset,$nowarn);
 237 }
 238
 239 #=======================================================================
 240 #
 241 # add_script_code_alias ( CODE,NEW_CODE [,CODESET] )
 242 #
 243 #=======================================================================
 244
 245 sub add_script_code_alias {
 246    my($code,$new_code,@args) = @_;
 247    my $nowarn   = 0;
 248    $nowarn      = 1, pop(@args)  if ($args[$#args] eq "nowarn");
 249    my $codeset  = shift(@args);
 250    my $err;
 251    ($err,$code,$codeset)     = _code($code,$codeset);
 252    ($err,$new_code,$codeset) = _code($new_code,$codeset)  if (! $err);
 253
 254    return Locale::Codes::_add_code_alias("script",$code,$new_code,$codeset,$nowarn);
 255 }
 256
 257 #=======================================================================
 258 #
 259 # delete_script_code_alias ( CODE [,CODESET] )
 260 #
 261 #=======================================================================
 262
 263 sub delete_script_code_alias {
 264    my($code,@args) = @_;
 265    my $nowarn   = 0;
 266    $nowarn      = 1, pop(@args)  if ($args[$#args] eq "nowarn");
 267    my $codeset  = shift(@args);
 268    my $err;
 269    ($err,$code,$codeset)     = _code($code,$codeset);
 270
 271    return Locale::Codes::_delete_code_alias("script",$code,$codeset,$nowarn);
 272 }
 273
 274 1;
 275 # Local Variables:
 276 # mode: cperl
 277 # indent-tabs-mode: nil
 278 # cperl-indent-level: 3
 279 # cperl-continued-statement-offset: 2
 280 # cperl-continued-brace-offset: 0
 281 # cperl-brace-offset: 0
 282 # cperl-brace-imaginary-offset: 0
 283 # cperl-label-offset: -2
 284 # End: