1package Encode::Alias;
2use strict;
3no warnings 'redefine';
4use Encode;
5our $VERSION = do { my @r = (q$Revision: 1.38 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
6sub DEBUG () { 0 }
7
8use base qw(Exporter);
9
10# Public, encouraged API is exported by default
11
12our @EXPORT =
13    qw (
14	define_alias
15	find_alias
16	);
17
18our @Alias;  # ordered matching list
19our %Alias;  # cached known aliases
20
21sub 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
73sub 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
103our @Latin2iso = ( 0, 1, 2, 3, 4, 9, 10, 13, 14, 15, 16 );
104# Allow winlatin1 style names as well
105our %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
117init_aliases();
118
119sub undef_aliases{
120    @Alias = ();
121    %Alias = ();
122}
123
124sub 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/\bkoi8[\s-_]*([ru])$/i => '"koi8-$1"' );
197
198    unless ($Encode::ON_EBCDIC){
199        # for Encode::CN
200	define_alias( qr/\beuc.*cn$/i        => '"euc-cn"' );
201	define_alias( qr/\bcn.*euc$/i        => '"euc-cn"' );
202	# define_alias( qr/\bGB[- ]?(\d+)$/i => '"euc-cn"' )
203	# CP936 doesn't have vendor-addon for GBK, so they're identical.
204	define_alias( qr/^gbk$/i => '"cp936"');
205	# This fixes gb2312 vs. euc-cn confusion, practically
206	define_alias( qr/\bGB[-_ ]?2312(?!-?raw)/i => '"euc-cn"' );
207	# for Encode::JP
208	define_alias( qr/\bjis$/i            => '"7bit-jis"' );
209	define_alias( qr/\beuc.*jp$/i        => '"euc-jp"' );
210	define_alias( qr/\bjp.*euc$/i        => '"euc-jp"' );
211	define_alias( qr/\bujis$/i           => '"euc-jp"' );
212	define_alias( qr/\bshift.*jis$/i     => '"shiftjis"' );
213	define_alias( qr/\bsjis$/i           => '"shiftjis"' );
214        # for Encode::KR
215	define_alias( qr/\beuc.*kr$/i        => '"euc-kr"' );
216	define_alias( qr/\bkr.*euc$/i        => '"euc-kr"' );
217	# This fixes ksc5601 vs. euc-kr confusion, practically
218        define_alias( qr/(?:x-)?uhc$/i            => '"cp949"' );
219        define_alias( qr/(?:x-)?windows-949$/i    => '"cp949"' );
220        define_alias( qr/\bks_c_5601-1987$/i      => '"cp949"' );
221        # for Encode::TW
222	define_alias( qr/\bbig-?5$/i		  => '"big5-eten"' );
223	define_alias( qr/\bbig5-?et(?:en)?$/i	  => '"big5-eten"' );
224	define_alias( qr/\btca[-_]?big5$/i	  => '"big5-eten"' );
225	define_alias( qr/\bbig5-?hk(?:scs)?$/i	  => '"big5-hkscs"' );
226	define_alias( qr/\bhk(?:scs)?[-_]?big5$/i  => '"big5-hkscs"' );
227    }
228    # utf8 is blessed :)
229    define_alias( qr/^UTF-8$/i => '"utf8"',);
230    # At last, Map white space and _ to '-'
231    define_alias( qr/^(\S+)[\s_]+(.*)$/i => '"$1-$2"' );
232}
233
2341;
235__END__
236
237# TODO: HP-UX '8' encodings arabic8 greek8 hebrew8 kana8 thai8 turkish8
238# TODO: HP-UX '15' encodings japanese15 korean15 roi15
239# TODO: Cyrillic encoding ISO-IR-111 (useful?)
240# TODO: Armenian encoding ARMSCII-8
241# TODO: Hebrew encoding ISO-8859-8-1
242# TODO: Thai encoding TCVN
243# TODO: Vietnamese encodings VPS
244# TODO: Mac Asian+African encodings: Arabic Armenian Bengali Burmese
245#       ChineseSimp ChineseTrad Devanagari Ethiopic ExtArabic
246#       Farsi Georgian Gujarati Gurmukhi Hebrew Japanese
247#       Kannada Khmer Korean Laotian Malayalam Mongolian
248#       Oriya Sinhalese Symbol Tamil Telugu Tibetan Vietnamese
249
250=head1 NAME
251
252Encode::Alias - alias definitions to encodings
253
254=head1 SYNOPSIS
255
256  use Encode;
257  use Encode::Alias;
258  define_alias( newName => ENCODING);
259
260=head1 DESCRIPTION
261
262Allows newName to be used as an alias for ENCODING. ENCODING may be
263either the name of an encoding or an encoding object (as described
264in L<Encode>).
265
266Currently I<newName> can be specified in the following ways:
267
268=over 4
269
270=item As a simple string.
271
272=item As a qr// compiled regular expression, e.g.:
273
274  define_alias( qr/^iso8859-(\d+)$/i => '"iso-8859-$1"' );
275
276In this case, if I<ENCODING> is not a reference, it is C<eval>-ed
277in order to allow C<$1> etc. to be substituted.  The example is one
278way to alias names as used in X11 fonts to the MIME names for the
279iso-8859-* family.  Note the double quotes inside the single quotes.
280
281(or, you don't have to do this yourself because this example is predefined)
282
283If you are using a regex here, you have to use the quotes as shown or
284it won't work.  Also note that regex handling is tricky even for the
285experienced.  Use this feature with caution.
286
287=item As a code reference, e.g.:
288
289  define_alias( sub {shift =~ /^iso8859-(\d+)$/i ? "iso-8859-$1" : undef } );
290
291The same effect as the example above in a different way.  The coderef
292takes the alias name as an argument and returns a canonical name on
293success or undef if not.  Note the second argument is not required.
294Use this with even more caution than the regex version.
295
296=back
297
298=head3 Changes in code reference aliasing
299
300As of Encode 1.87, the older form
301
302  define_alias( sub { return  /^iso8859-(\d+)$/i ? "iso-8859-$1" : undef } );
303
304no longer works.
305
306Encode up to 1.86 internally used "local $_" to implement ths older
307form.  But consider the code below;
308
309  use Encode;
310  $_ = "eeeee" ;
311  while (/(e)/g) {
312    my $utf = decode('aliased-encoding-name', $1);
313    print "position:",pos,"\n";
314  }
315
316Prior to Encode 1.86 this fails because of "local $_".
317
318=head2 Alias overloading
319
320You can override predefined aliases by simply applying define_alias().
321The new alias is always evaluated first, and when neccessary,
322define_alias() flushes the internal cache to make the new definition
323available.
324
325  # redirect SHIFT_JIS to MS/IBM Code Page 932, which is a
326  # superset of SHIFT_JIS
327
328  define_alias( qr/shift.*jis$/i  => '"cp932"' );
329  define_alias( qr/sjis$/i        => '"cp932"' );
330
331If you want to zap all predefined aliases, you can use
332
333  Encode::Alias->undef_aliases;
334
335to do so.  And
336
337  Encode::Alias->init_aliases;
338
339gets the factory settings back.
340
341=head1 SEE ALSO
342
343L<Encode>, L<Encode::Supported>
344
345=cut
346
347