ext/Encode/lib/Encode/Alias.pm

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