ext/Encode/lib/Encode/Alias.pm

   1 package Encode::Alias;
   2 use strict;
   3 use warnings;
   4 no warnings 'redefine';
   5 use Encode;
   6 our $VERSION = do { my @r = ( q$Revision: 2.6 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r };
   7 sub DEBUG () { 0 }
   8
   9 use base qw(Exporter);
  10
  11 # Public, encouraged API is exported by default
  12
  13 our @EXPORT =
  14   qw (
  15   define_alias
  16   find_alias
  17 );
  18
  19 our @Alias;    # ordered matching list
  20 our %Alias;    # cached known aliases
  21
  22 sub find_alias {
  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     undef_aliases();
 132
 133     # Try all-lower-case version should all else fails
 134     define_alias( qr/^(.*)$/ => '"\L$1"' );
 135
 136     # UTF/UCS stuff
 137     define_alias( qr/^UTF-?7$/i     => '"UTF-7"' );
 138     define_alias( qr/^UCS-?2-?LE$/i => '"UCS-2LE"' );
 139     define_alias(
 140         qr/^UCS-?2-?(BE)?$/i    => '"UCS-2BE"',
 141         qr/^UCS-?4-?(BE|LE)?$/i => 'uc("UTF-32$1")',
 142         qr/^iso-10646-1$/i      => '"UCS-2BE"'
 143     );
 144     define_alias(
 145         qr/^UTF-?(16|32)-?BE$/i => '"UTF-$1BE"',
 146         qr/^UTF-?(16|32)-?LE$/i => '"UTF-$1LE"',
 147         qr/^UTF-?(16|32)$/i     => '"UTF-$1"',
 148     );
 149
 150     # ASCII
 151     define_alias( qr/^(?:US-?)ascii$/i       => '"ascii"' );
 152     define_alias( 'C'                        => 'ascii' );
 153     define_alias( qr/\bISO[-_]?646[-_]?US$/i => '"ascii"' );
 154
 155     # Allow variants of iso-8859-1 etc.
 156     define_alias( qr/\biso[-_]?(\d+)[-_](\d+)$/i => '"iso-$1-$2"' );
 157
 158     # At least HP-UX has these.
 159     define_alias( qr/\biso8859(\d+)$/i => '"iso-8859-$1"' );
 160
 161     # More HP stuff.
 162     define_alias(
 163         qr/\b(?:hp-)?(arabic|greek|hebrew|kana|roman|thai|turkish)8$/i =>
 164           '"${1}8"' );
 165
 166     # The Official name of ASCII.
 167     define_alias( qr/\bANSI[-_]?X3\.4[-_]?1968$/i => '"ascii"' );
 168
 169     # This is a font issue, not an encoding issue.
 170     # (The currency symbol of the Latin 1 upper half
 171     #  has been redefined as the euro symbol.)
 172     define_alias( qr/^(.+)\@euro$/i => '"$1"' );
 173
 174     define_alias( qr/\b(?:iso[-_]?)?latin[-_]?(\d+)$/i =>
 175 'defined $Encode::Alias::Latin2iso[$1] ? "iso-8859-$Encode::Alias::Latin2iso[$1]" : undef'
 176     );
 177
 178     define_alias(
 179         qr/\bwin(latin[12]|cyrillic|baltic|greek|turkish|
 180              hebrew|arabic|baltic|vietnamese)$/ix =>
 181           '"cp" . $Encode::Alias::Winlatin2cp{lc($1)}'
 182     );
 183
 184     # Common names for non-latin preferred MIME names
 185     define_alias(
 186         'ascii'    => 'US-ascii',
 187         'cyrillic' => 'iso-8859-5',
 188         'arabic'   => 'iso-8859-6',
 189         'greek'    => 'iso-8859-7',
 190         'hebrew'   => 'iso-8859-8',
 191         'thai'     => 'iso-8859-11',
 192         'tis620'   => 'iso-8859-11',
 193     );
 194
 195     # At least AIX has IBM-NNN (surprisingly...) instead of cpNNN.
 196     # And Microsoft has their own naming (again, surprisingly).
 197     # And windows-* is registered in IANA!
 198     define_alias(
 199         qr/\b(?:cp|ibm|ms|windows)[-_ ]?(\d{2,4})$/i => '"cp$1"' );
 200
 201     # Sometimes seen with a leading zero.
 202     # define_alias( qr/\bcp037\b/i => '"cp37"');
 203
 204     # Mac Mappings
 205     # predefined in *.ucm; unneeded
 206     # define_alias( qr/\bmacIcelandic$/i => '"macIceland"');
 207     define_alias( qr/^mac_(.*)$/i => '"mac$1"' );
 208
 209     # Ououououou. gone.  They are differente!
 210     # define_alias( qr/\bmacRomanian$/i => '"macRumanian"');
 211
 212     # Standardize on the dashed versions.
 213     define_alias( qr/\bkoi8[\s\-_]*([ru])$/i => '"koi8-$1"' );
 214
 215     unless ($Encode::ON_EBCDIC) {
 216
 217         # for Encode::CN
 218         define_alias( qr/\beuc.*cn$/i => '"euc-cn"' );
 219         define_alias( qr/\bcn.*euc$/i => '"euc-cn"' );
 220
 221         # define_alias( qr/\bGB[- ]?(\d+)$/i => '"euc-cn"' )
 222         # CP936 doesn't have vendor-addon for GBK, so they're identical.
 223         define_alias( qr/^gbk$/i => '"cp936"' );
 224
 225         # This fixes gb2312 vs. euc-cn confusion, practically
 226         define_alias( qr/\bGB[-_ ]?2312(?!-?raw)/i => '"euc-cn"' );
 227
 228         # for Encode::JP
 229         define_alias( qr/\bjis$/i         => '"7bit-jis"' );
 230         define_alias( qr/\beuc.*jp$/i     => '"euc-jp"' );
 231         define_alias( qr/\bjp.*euc$/i     => '"euc-jp"' );
 232         define_alias( qr/\bujis$/i        => '"euc-jp"' );
 233         define_alias( qr/\bshift.*jis$/i  => '"shiftjis"' );
 234         define_alias( qr/\bsjis$/i        => '"shiftjis"' );
 235         define_alias( qr/\bwindows-31j$/i => '"cp932"' );
 236
 237         # for Encode::KR
 238         define_alias( qr/\beuc.*kr$/i => '"euc-kr"' );
 239         define_alias( qr/\bkr.*euc$/i => '"euc-kr"' );
 240
 241         # This fixes ksc5601 vs. euc-kr confusion, practically
 242         define_alias( qr/(?:x-)?uhc$/i         => '"cp949"' );
 243         define_alias( qr/(?:x-)?windows-949$/i => '"cp949"' );
 244         define_alias( qr/\bks_c_5601-1987$/i   => '"cp949"' );
 245
 246         # for Encode::TW
 247         define_alias( qr/\bbig-?5$/i              => '"big5-eten"' );
 248         define_alias( qr/\bbig5-?et(?:en)?$/i     => '"big5-eten"' );
 249         define_alias( qr/\btca[-_]?big5$/i        => '"big5-eten"' );
 250         define_alias( qr/\bbig5-?hk(?:scs)?$/i    => '"big5-hkscs"' );
 251         define_alias( qr/\bhk(?:scs)?[-_]?big5$/i => '"big5-hkscs"' );
 252     }
 253
 254     # utf8 is blessed :)
 255     define_alias( qr/^UTF-8$/i => '"utf-8-strict"' );
 256
 257     # At last, Map white space and _ to '-'
 258     define_alias( qr/^(\S+)[\s_]+(.*)$/i => '"$1-$2"' );
 259 }
 260
 261 1;
 262 __END__
 263
 264 # TODO: HP-UX '8' encodings arabic8 greek8 hebrew8 kana8 thai8 turkish8
 265 # TODO: HP-UX '15' encodings japanese15 korean15 roi15
 266 # TODO: Cyrillic encoding ISO-IR-111 (useful?)
 267 # TODO: Armenian encoding ARMSCII-8
 268 # TODO: Hebrew encoding ISO-8859-8-1
 269 # TODO: Thai encoding TCVN
 270 # TODO: Vietnamese encodings VPS
 271 # TODO: Mac Asian+African encodings: Arabic Armenian Bengali Burmese
 272 #       ChineseSimp ChineseTrad Devanagari Ethiopic ExtArabic
 273 #       Farsi Georgian Gujarati Gurmukhi Hebrew Japanese
 274 #       Kannada Khmer Korean Laotian Malayalam Mongolian
 275 #       Oriya Sinhalese Symbol Tamil Telugu Tibetan Vietnamese
 276
 277 =head1 NAME
 278
 279 Encode::Alias - alias definitions to encodings
 280
 281 =head1 SYNOPSIS
 282
 283   use Encode;
 284   use Encode::Alias;
 285   define_alias( newName => ENCODING);
 286
 287 =head1 DESCRIPTION
 288
 289 Allows newName to be used as an alias for ENCODING. ENCODING may be
 290 either the name of an encoding or an encoding object (as described
 291 in L<Encode>).
 292
 293 Currently I<newName> can be specified in the following ways:
 294
 295 =over 4
 296
 297 =item As a simple string.
 298
 299 =item As a qr// compiled regular expression, e.g.:
 300
 301   define_alias( qr/^iso8859-(\d+)$/i => '"iso-8859-$1"' );
 302
 303 In this case, if I<ENCODING> is not a reference, it is C<eval>-ed
 304 in order to allow C<$1> etc. to be substituted.  The example is one
 305 way to alias names as used in X11 fonts to the MIME names for the
 306 iso-8859-* family.  Note the double quotes inside the single quotes.
 307
 308 (or, you don't have to do this yourself because this example is predefined)
 309
 310 If you are using a regex here, you have to use the quotes as shown or
 311 it won't work.  Also note that regex handling is tricky even for the
 312 experienced.  Use this feature with caution.
 313
 314 =item As a code reference, e.g.:
 315
 316   define_alias( sub {shift =~ /^iso8859-(\d+)$/i ? "iso-8859-$1" : undef } );
 317
 318 The same effect as the example above in a different way.  The coderef
 319 takes the alias name as an argument and returns a canonical name on
 320 success or undef if not.  Note the second argument is not required.
 321 Use this with even more caution than the regex version.
 322
 323 =back
 324
 325 =head3 Changes in code reference aliasing
 326
 327 As of Encode 1.87, the older form
 328
 329   define_alias( sub { return  /^iso8859-(\d+)$/i ? "iso-8859-$1" : undef } );
 330
 331 no longer works.
 332
 333 Encode up to 1.86 internally used "local $_" to implement ths older
 334 form.  But consider the code below;
 335
 336   use Encode;
 337   $_ = "eeeee" ;
 338   while (/(e)/g) {
 339     my $utf = decode('aliased-encoding-name', $1);
 340     print "position:",pos,"\n";
 341   }
 342
 343 Prior to Encode 1.86 this fails because of "local $_".
 344
 345 =head2 Alias overloading
 346
 347 You can override predefined aliases by simply applying define_alias().
 348 The new alias is always evaluated first, and when necessary,
 349 define_alias() flushes the internal cache to make the new definition
 350 available.
 351
 352   # redirect SHIFT_JIS to MS/IBM Code Page 932, which is a
 353   # superset of SHIFT_JIS
 354
 355   define_alias( qr/shift.*jis$/i  => '"cp932"' );
 356   define_alias( qr/sjis$/i        => '"cp932"' );
 357
 358 If you want to zap all predefined aliases, you can use
 359
 360   Encode::Alias->undef_aliases;
 361
 362 to do so.  And
 363
 364   Encode::Alias->init_aliases;
 365
 366 gets the factory settings back.
 367
 368 =head1 SEE ALSO
 369
 370 L<Encode>, L<Encode::Supported>
 371
 372 =cut
 373