This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
"646"
[perl5.git] / ext / Encode / lib / Encode / Alias.pm
1 package Encode::Alias;
2 use strict;
3 use warnings;
4 no warnings 'redefine';
5 our $VERSION = '2.8_01';# do { my @r = ( q$Revision: 2.8 $ =~ /\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