ext/Encode/lib/Encode/Alias.pm

   1 package Encode::Alias;
   2 use strict;
   3 no warnings 'redefine';
   4 use Encode;
   5 our $VERSION = do { my @r = (q$Revision: 1.37 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
   6 sub DEBUG () { 0 }
   7
   8 use base qw(Exporter);
   9
  10 # Public, encouraged API is exported by default
  11
  12 our @EXPORT =
  13     qw (
  14         define_alias
  15         find_alias
  16         );
  17
  18 our @Alias;  # ordered matching list
  19 our %Alias;  # cached known aliases
  20
  21 sub find_alias
  22 {
  23     my $class = shift;
  24     my $find = shift;
  25     unless (exists $Alias{$find})
  26     {
  27         $Alias{$find} = undef; # Recursion guard
  28         for (my $i=0; $i < @Alias; $i += 2)
  29         {
  30             my $alias = $Alias[$i];
  31             my $val   = $Alias[$i+1];
  32             my $new;
  33             if (ref($alias) eq 'Regexp' && $find =~ $alias)
  34             {
  35                 DEBUG and warn "eval $val";
  36                 $new = eval $val;
  37                 DEBUG and $@ and warn "$val, $@";
  38             }
  39             elsif (ref($alias) eq 'CODE')
  40             {
  41                 DEBUG and warn "$alias", "->", "($find)";
  42                 $new = $alias->($find);
  43             }
  44             elsif (lc($find) eq lc($alias))
  45             {
  46                 $new = $val;
  47             }
  48             if (defined($new))
  49             {
  50                 next if $new eq $find; # avoid (direct) recursion on bugs
  51                 DEBUG and warn "$alias, $new";
  52                 my $enc = (ref($new)) ? $new : Encode::find_encoding($new);
  53                 if ($enc)
  54                 {
  55                     $Alias{$find} = $enc;
  56                     last;
  57                 }
  58             }
  59         }
  60     }
  61     if (DEBUG){
  62         my $name;
  63         if (my $e = $Alias{$find}){
  64             $name = $e->name;
  65         }else{
  66             $name = "";
  67         }
  68         warn "find_alias($class, $find)->name = $name";
  69     }
  70     return $Alias{$find};
  71 }
  72
  73 sub define_alias
  74 {
  75     while (@_)
  76     {
  77         my ($alias,$name) = splice(@_,0,2);
  78         unshift(@Alias, $alias => $name);   # newer one has precedence
  79         # clear %Alias cache to allow overrides
  80         if (ref($alias)){
  81             my @a = keys %Alias;
  82             for my $k (@a){
  83                 if (ref($alias) eq 'Regexp' && $k =~ $alias)
  84                 {
  85                     DEBUG and warn "delete \$Alias\{$k\}";
  86                     delete $Alias{$k};
  87                 }
  88                 elsif (ref($alias) eq 'CODE')
  89                 {
  90                     DEBUG and warn "delete \$Alias\{$k\}";
  91                     delete $Alias{$alias->($name)};
  92                 }
  93             }
  94         }else{
  95             DEBUG and warn "delete \$Alias\{$alias\}";
  96             delete $Alias{$alias};
  97         }
  98     }
  99 }
 100
 101 # Allow latin-1 style names as well
 102                      # 0  1  2  3  4  5   6   7   8   9  10
 103 our @Latin2iso = ( 0, 1, 2, 3, 4, 9, 10, 13, 14, 15, 16 );
 104 # Allow winlatin1 style names as well
 105 our %Winlatin2cp   = (
 106                       'latin1'     => 1252,
 107                       'latin2'     => 1250,
 108                       'cyrillic'   => 1251,
 109                       'greek'      => 1253,
 110                       'turkish'    => 1254,
 111                       'hebrew'     => 1255,
 112                       'arabic'     => 1256,
 113                       'baltic'     => 1257,
 114                       'vietnamese' => 1258,
 115                      );
 116
 117 init_aliases();
 118
 119 sub undef_aliases{
 120     @Alias = ();
 121     %Alias = ();
 122 }
 123
 124 sub init_aliases
 125 {
 126     undef_aliases();
 127
 128     # Try all-lower-case version should all else fails
 129     define_alias( qr/^(.*)$/ => '"\L$1"' );
 130
 131     # UTF/UCS stuff
 132     define_alias( qr/^UTF-?7$/i           => '"UTF-7"');
 133     define_alias( qr/^UCS-?2-?LE$/i       => '"UCS-2LE"' );
 134     define_alias( qr/^UCS-?2-?(BE)?$/i    => '"UCS-2BE"',
 135                   qr/^UCS-?4-?(BE|LE)?$/i => 'uc("UTF-32$1")',
 136                   qr/^iso-10646-1$/i      => '"UCS-2BE"' );
 137     define_alias( qr/^UTF(16|32)-?BE$/i   => '"UTF-$1BE"',
 138                   qr/^UTF(16|32)-?LE$/i   => '"UTF-$1LE"',
 139                   qr/^UTF(16|32)$/i       => '"UTF-$1"',
 140                 );
 141     # ASCII
 142     define_alias(qr/^(?:US-?)ascii$/i => '"ascii"');
 143     define_alias('C' => 'ascii');
 144     define_alias(qr/\bISO[-_]?646[-_]?US$/i => '"ascii"');
 145     # Allow variants of iso-8859-1 etc.
 146     define_alias( qr/\biso[-_]?(\d+)[-_](\d+)$/i => '"iso-$1-$2"' );
 147
 148     # At least HP-UX has these.
 149     define_alias( qr/\biso8859(\d+)$/i => '"iso-8859-$1"' );
 150
 151     # More HP stuff.
 152     define_alias( qr/\b(?:hp-)?(arabic|greek|hebrew|kana|roman|thai|turkish)8$/i => '"${1}8"' );
 153
 154     # The Official name of ASCII.
 155     define_alias( qr/\bANSI[-_]?X3\.4[-_]?1968$/i => '"ascii"' );
 156
 157     # This is a font issue, not an encoding issue.
 158     # (The currency symbol of the Latin 1 upper half
 159     #  has been redefined as the euro symbol.)
 160     define_alias( qr/^(.+)\@euro$/i => '"$1"' );
 161
 162     define_alias( qr/\b(?:iso[-_]?)?latin[-_]?(\d+)$/i
 163                   => 'defined $Encode::Alias::Latin2iso[$1] ? "iso-8859-$Encode::Alias::Latin2iso[$1]" : undef' );
 164
 165     define_alias( qr/\bwin(latin[12]|cyrillic|baltic|greek|turkish|
 166                          hebrew|arabic|baltic|vietnamese)$/ix =>
 167                   '"cp" . $Encode::Alias::Winlatin2cp{lc($1)}' );
 168
 169     # Common names for non-latin prefered MIME names
 170     define_alias( 'ascii'    => 'US-ascii',
 171                   'cyrillic' => 'iso-8859-5',
 172                   'arabic'   => 'iso-8859-6',
 173                   'greek'    => 'iso-8859-7',
 174                   'hebrew'   => 'iso-8859-8',
 175                   'thai'     => 'iso-8859-11',
 176                   'tis620'   => 'iso-8859-11',
 177                   );
 178
 179     # At least AIX has IBM-NNN (surprisingly...) instead of cpNNN.
 180     # And Microsoft has their own naming (again, surprisingly).
 181     # And windows-* is registered in IANA!
 182     define_alias( qr/\b(?:cp|ibm|ms|windows)[-_ ]?(\d{2,4})$/i => '"cp$1"');
 183
 184     # Sometimes seen with a leading zero.
 185     # define_alias( qr/\bcp037\b/i => '"cp37"');
 186
 187     # Mac Mappings
 188     # predefined in *.ucm; unneeded
 189     # define_alias( qr/\bmacIcelandic$/i => '"macIceland"');
 190     define_alias( qr/^mac_(.*)$/i => '"mac$1"');
 191     # Ououououou. gone.  They are differente!
 192     # define_alias( qr/\bmacRomanian$/i => '"macRumanian"');
 193
 194     # Standardize on the dashed versions.
 195     # define_alias( qr/\butf8$/i  => 'utf-8' );
 196     define_alias( qr/\bkoi8r$/i => 'koi8-r' );
 197     define_alias( qr/\bkoi8u$/i => 'koi8-u' );
 198
 199     unless ($Encode::ON_EBCDIC){
 200         # for Encode::CN
 201         define_alias( qr/\beuc.*cn$/i        => '"euc-cn"' );
 202         define_alias( qr/\bcn.*euc$/i        => '"euc-cn"' );
 203         # define_alias( qr/\bGB[- ]?(\d+)$/i => '"euc-cn"' )
 204         # CP936 doesn't have vendor-addon for GBK, so they're identical.
 205         define_alias( qr/^gbk$/i => '"cp936"');
 206         # This fixes gb2312 vs. euc-cn confusion, practically
 207         define_alias( qr/\bGB[-_ ]?2312(?!-?raw)/i => '"euc-cn"' );
 208         # for Encode::JP
 209         define_alias( qr/\bjis$/i            => '"7bit-jis"' );
 210         define_alias( qr/\beuc.*jp$/i        => '"euc-jp"' );
 211         define_alias( qr/\bjp.*euc$/i        => '"euc-jp"' );
 212         define_alias( qr/\bujis$/i           => '"euc-jp"' );
 213         define_alias( qr/\bshift.*jis$/i     => '"shiftjis"' );
 214         define_alias( qr/\bsjis$/i           => '"shiftjis"' );
 215         # for Encode::KR
 216         define_alias( qr/\beuc.*kr$/i        => '"euc-kr"' );
 217         define_alias( qr/\bkr.*euc$/i        => '"euc-kr"' );
 218         # This fixes ksc5601 vs. euc-kr confusion, practically
 219         define_alias( qr/(?:x-)?uhc$/i            => '"cp949"' );
 220         define_alias( qr/(?:x-)?windows-949$/i    => '"cp949"' );
 221         define_alias( qr/\bks_c_5601-1987$/i      => '"cp949"' );
 222         # for Encode::TW
 223         define_alias( qr/\bbig-?5$/i              => '"big5-eten"' );
 224         define_alias( qr/\bbig5-?et(?:en)?$/i     => '"big5-eten"' );
 225         define_alias( qr/\btca[-_]?big5$/i        => '"big5-eten"' );
 226         define_alias( qr/\bbig5-?hk(?:scs)?$/i    => '"big5-hkscs"' );
 227         define_alias( qr/\bhk(?:scs)?[-_]?big5$/i  => '"big5-hkscs"' );
 228     }
 229     # utf8 is blessed :)
 230     define_alias( qr/^UTF-8$/i => '"utf8"',);
 231     # At last, Map white space and _ to '-'
 232     define_alias( qr/^(\S+)[\s_]+(.*)$/i => '"$1-$2"' );
 233 }
 234
 235 1;
 236 __END__
 237
 238 # TODO: HP-UX '8' encodings arabic8 greek8 hebrew8 kana8 thai8 turkish8
 239 # TODO: HP-UX '15' encodings japanese15 korean15 roi15
 240 # TODO: Cyrillic encoding ISO-IR-111 (useful?)
 241 # TODO: Armenian encoding ARMSCII-8
 242 # TODO: Hebrew encoding ISO-8859-8-1
 243 # TODO: Thai encoding TCVN
 244 # TODO: Vietnamese encodings VPS
 245 # TODO: Mac Asian+African encodings: Arabic Armenian Bengali Burmese
 246 #       ChineseSimp ChineseTrad Devanagari Ethiopic ExtArabic
 247 #       Farsi Georgian Gujarati Gurmukhi Hebrew Japanese
 248 #       Kannada Khmer Korean Laotian Malayalam Mongolian
 249 #       Oriya Sinhalese Symbol Tamil Telugu Tibetan Vietnamese
 250
 251 =head1 NAME
 252
 253 Encode::Alias - alias definitions to encodings
 254
 255 =head1 SYNOPSIS
 256
 257   use Encode;
 258   use Encode::Alias;
 259   define_alias( newName => ENCODING);
 260
 261 =head1 DESCRIPTION
 262
 263 Allows newName to be used as an alias for ENCODING. ENCODING may be
 264 either the name of an encoding or an encoding object (as described
 265 in L<Encode>).
 266
 267 Currently I<newName> can be specified in the following ways:
 268
 269 =over 4
 270
 271 =item As a simple string.
 272
 273 =item As a qr// compiled regular expression, e.g.:
 274
 275   define_alias( qr/^iso8859-(\d+)$/i => '"iso-8859-$1"' );
 276
 277 In this case, if I<ENCODING> is not a reference, it is C<eval>-ed
 278 in order to allow C<$1> etc. to be substituted.  The example is one
 279 way to alias names as used in X11 fonts to the MIME names for the
 280 iso-8859-* family.  Note the double quotes inside the single quotes.
 281
 282 (or, you don't have to do this yourself because this example is predefined)
 283
 284 If you are using a regex here, you have to use the quotes as shown or
 285 it won't work.  Also note that regex handling is tricky even for the
 286 experienced.  Use this feature with caution.
 287
 288 =item As a code reference, e.g.:
 289
 290   define_alias( sub {shift =~ /^iso8859-(\d+)$/i ? "iso-8859-$1" : undef } );
 291
 292 The same effect as the example above in a different way.  The coderef
 293 takes the alias name as an argument and returns a canonical name on
 294 success or undef if not.  Note the second argument is not required.
 295 Use this with even more caution than the regex version.
 296
 297 =back
 298
 299 =head3 Changes in code reference aliasing
 300
 301 As of Encode 1.87, the older form
 302
 303   define_alias( sub { return  /^iso8859-(\d+)$/i ? "iso-8859-$1" : undef } );
 304
 305 no longer works.
 306
 307 Encode up to 1.86 internally used "local $_" to implement ths older
 308 form.  But consider the code below;
 309
 310   use Encode;
 311   $_ = "eeeee" ;
 312   while (/(e)/g) {
 313     my $utf = decode('aliased-encoding-name', $1);
 314     print "position:",pos,"\n";
 315   }
 316
 317 Prior to Encode 1.86 this fails because of "local $_".
 318
 319 =head2 Alias overloading
 320
 321 You can override predefined aliases by simply applying define_alias().
 322 The new alias is always evaluated first, and when neccessary,
 323 define_alias() flushes the internal cache to make the new definition
 324 available.
 325
 326   # redirect SHIFT_JIS to MS/IBM Code Page 932, which is a
 327   # superset of SHIFT_JIS
 328
 329   define_alias( qr/shift.*jis$/i  => '"cp932"' );
 330   define_alias( qr/sjis$/i        => '"cp932"' );
 331
 332 If you want to zap all predefined aliases, you can use
 333
 334   Encode::Alias->undef_aliases;
 335
 336 to do so.  And
 337
 338   Encode::Alias->init_aliases;
 339
 340 gets the factory settings back.
 341
 342 =head1 SEE ALSO
 343
 344 L<Encode>, L<Encode::Supported>
 345
 346 =cut
 347