This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perluniintro vs Encode::Alias] Is KOI8R is an alise for koi8-r?
[perl5.git] / 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