ext/Encode/Unicode/Unicode.pm

   1 package Encode::Unicode;
   2
   3 use strict;
   4 use warnings;
   5
   6 our $VERSION = do { my @r = (q$Revision: 1.38 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
   7
   8 use XSLoader;
   9 XSLoader::load(__PACKAGE__,$VERSION);
  10
  11 #
  12 # Object Generator 8 transcoders all at once!
  13 #
  14
  15 require Encode;
  16
  17 for my $name (qw(UTF-16 UTF-16BE UTF-16LE
  18                  UTF-32 UTF-32BE UTF-32LE
  19                         UCS-2BE  UCS-2LE))
  20 {
  21     my ($size, $endian, $ucs2, $mask);
  22     $name =~ /^(\w+)-(\d+)(\w*)$/o;
  23     if ($ucs2 = ($1 eq 'UCS')){
  24         $size = 2;
  25     }else{
  26         $size = $2/8;
  27     }
  28     $endian = ($3 eq 'BE') ? 'n' : ($3 eq 'LE') ? 'v' : '' ;
  29     $size == 4 and $endian = uc($endian);
  30
  31     $Encode::Encoding{$name} =
  32         bless {
  33                Name   =>   $name,
  34                size   =>   $size,
  35                endian => $endian,
  36                ucs2   =>   $ucs2,
  37               } => __PACKAGE__;
  38
  39 }
  40
  41 use base qw(Encode::Encoding);
  42
  43 #
  44 # three implementations of (en|de)code exist.  The XS version is the
  45 # fastest.  *_modern uses an array and *_classic sticks with substr.
  46 # *_classic is  much slower but more memory conservative.
  47 # *_xs is the default.
  48
  49 sub set_transcoder{
  50     no warnings qw(redefine);
  51     my $type = shift;
  52     if    ($type eq "xs"){
  53         *decode = \&decode_xs;
  54         *encode = \&encode_xs;
  55     }elsif($type eq "modern"){
  56         *decode = \&decode_modern;
  57         *encode = \&encode_modern;
  58     }elsif($type eq "classic"){
  59         *decode = \&decode_classic;
  60         *encode = \&encode_classic;
  61     }else{
  62         require Carp;
  63         Carp::croak __PACKAGE__, "::set_transcoder(modern|classic|xs)";
  64     }
  65 }
  66
  67 set_transcoder("xs");
  68
  69 #
  70 # Aux. subs & constants
  71 #
  72
  73 sub FBCHAR(){ 0xFFFd }
  74 sub BOM_BE(){ 0xFeFF }
  75 sub BOM16LE(){ 0xFFFe }
  76 sub BOM32LE(){ 0xFFFe0000 }
  77
  78 sub valid_ucs2($){
  79     return
  80         (0 <= $_[0] && $_[0] < 0xD800)
  81             ||  ( 0xDFFF < $_[0] && $_[0] <= 0xFFFF);
  82 }
  83
  84 sub issurrogate($){   0xD800 <= $_[0]  && $_[0] <= 0xDFFF }
  85 sub isHiSurrogate($){ 0xD800 <= $_[0]  && $_[0] <  0xDC00 }
  86 sub isLoSurrogate($){ 0xDC00 <= $_[0]  && $_[0] <= 0xDFFF }
  87
  88 sub ensurrogate($){
  89     use integer; # we have divisions
  90     my $uni = shift;
  91     my  $hi = ($uni - 0x10000) / 0x400 + 0xD800;
  92     my  $lo = ($uni - 0x10000) % 0x400 + 0xDC00;
  93     return ($hi, $lo);
  94 }
  95
  96 sub desurrogate($$){
  97     my ($hi, $lo) = @_;
  98     return 0x10000 + ($hi - 0xD800)*0x400 + ($lo - 0xDC00);
  99 }
 100
 101 sub Mask { {2 => 0xffff,  4 => 0xffffffff} }
 102
 103 #
 104 # *_modern are much faster but guzzle more memory
 105 #
 106
 107 sub decode_modern($$;$)
 108 {
 109     my ($obj, $str, $chk ) = @_;
 110     my ($size, $endian, $ucs2) = @$obj{qw(size endian ucs2)};
 111
 112     # warn "$size, $endian, $ucs2";
 113     $endian ||= BOMB($size, substr($str, 0, $size, ''))
 114         or poisoned2death($obj, "Where's the BOM?");
 115     my  $mask = Mask->{$size};
 116     my $utf8   = '';
 117     my @ord = unpack("$endian*", $str);
 118     undef $str; # to conserve memory
 119     while (@ord){
 120         my $ord = shift @ord;
 121         unless ($size == 4 or valid_ucs2($ord &= $mask)){
 122             if ($ucs2){
 123                 $chk and
 124                     poisoned2death($obj, "no surrogates allowed", $ord);
 125                 shift @ord; # skip the next one as well
 126                 $ord = FBCHAR;
 127             }else{
 128                 unless (isHiSurrogate($ord)){
 129                     poisoned2death($obj, "Malformed HI surrogate", $ord);
 130                 }
 131                 my $lo = shift @ord;
 132                 unless (isLoSurrogate($lo &= $mask)){
 133                     poisoned2death($obj, "Malformed LO surrogate", $ord, $lo);
 134                 }
 135                 $ord = desurrogate($ord, $lo);
 136             }
 137         }
 138         $utf8 .= chr($ord);
 139     }
 140     utf8::upgrade($utf8);
 141     return $utf8;
 142 }
 143
 144 sub encode_modern($$;$)
 145 {
 146     my ($obj, $utf8, $chk) = @_;
 147     my ($size, $endian, $ucs2) = @$obj{qw(size endian ucs2)};
 148     my @str = ();
 149     unless ($endian){
 150         $endian = ($size == 4) ? 'N' : 'n';
 151         push @str, BOM_BE;
 152     }
 153     my @ord = unpack("U*", $utf8);
 154     undef $utf8; # to conserve memory
 155     for my $ord (@ord){
 156         unless ($size == 4 or valid_ucs2($ord)) {
 157             unless(issurrogate($ord)){
 158                 if ($ucs2){
 159                     $chk and
 160                         poisoned2death($obj, "code point too high", $ord);
 161
 162                     push @str, FBCHAR;
 163                 }else{
 164
 165                     push @str, ensurrogate($ord);
 166                 }
 167             }else{  # not supposed to happen
 168                 push @str, FBCHAR;
 169             }
 170         }else{
 171             push @str, $ord;
 172         }
 173     }
 174     return pack("$endian*", @str);
 175 }
 176
 177 #
 178 # *_classic are slower but more memory conservative
 179 #
 180
 181 sub decode_classic($$;$)
 182 {
 183     my ($obj, $str, $chk ) = @_;
 184     my ($size, $endian, $ucs2) = @$obj{qw(size endian ucs2)};
 185
 186     # warn "$size, $endian, $ucs2";
 187     $endian ||= BOMB($size, substr($str, 0, $size, ''))
 188         or poisoned2death($obj, "Where's the BOM?");
 189     my  $mask = Mask->{$size};
 190     my $utf8   = '';
 191     my @ord = unpack("$endian*", $str);
 192     while (length($str)){
 193          my $ord = unpack($endian, substr($str, 0, $size, ''));
 194         unless ($size == 4 or valid_ucs2($ord &= $mask)){
 195             if ($ucs2){
 196                 $chk and
 197                     poisoned2death($obj, "no surrogates allowed", $ord);
 198                 substr($str,0,$size,''); # skip the next one as well
 199                 $ord = FBCHAR;
 200             }else{
 201                 unless (isHiSurrogate($ord)){
 202                     poisoned2death($obj, "Malformed HI surrogate", $ord);
 203                 }
 204                 my $lo = unpack($endian ,substr($str,0,$size,''));
 205                 unless (isLoSurrogate($lo &= $mask)){
 206                     poisoned2death($obj, "Malformed LO surrogate", $ord, $lo);
 207                 }
 208                 $ord = desurrogate($ord, $lo);
 209             }
 210         }
 211         $utf8 .= chr($ord);
 212     }
 213     utf8::upgrade($utf8);
 214     return $utf8;
 215 }
 216
 217 sub encode_classic($$;$)
 218 {
 219     my ($obj, $utf8, $chk) = @_;
 220     my ($size, $endian, $ucs2) = @$obj{qw(size endian ucs2)};
 221     # warn join ", ", $size, $ucs2, $endian, $mask;
 222     my $str   = '';
 223     unless ($endian){
 224         $endian = ($size == 4) ? 'N' : 'n';
 225         $str .= pack($endian, BOM_BE);
 226     }
 227     while (length($utf8)){
 228         my $ord  = ord(substr($utf8,0,1,''));
 229         unless ($size == 4 or valid_ucs2($ord)) {
 230             unless(issurrogate($ord)){
 231                 if ($ucs2){
 232                     $chk and
 233                         poisoned2death($obj, "code point too high", $ord);
 234                     $str .= pack($endian, FBCHAR);
 235                 }else{
 236                     $str .= pack($endian.2, ensurrogate($ord));
 237                 }
 238             }else{  # not supposed to happen
 239                 $str .= pack($endian, FBCHAR);
 240             }
 241         }else{
 242             $str .= pack($endian, $ord);
 243         }
 244     }
 245     return $str;
 246 }
 247
 248 sub BOMB {
 249     my ($size, $bom) = @_;
 250     my $N = $size == 2 ? 'n' : 'N';
 251     my $ord = unpack($N, $bom);
 252     return ($ord eq BOM_BE) ? $N :
 253         ($ord eq BOM16LE) ? 'v' : ($ord eq BOM32LE) ? 'V' : undef;
 254 }
 255
 256 sub poisoned2death{
 257     my $obj = shift;
 258     my $msg = shift;
 259     my $pair = join(", ", map {sprintf "\\x%x", $_} @_);
 260     require Carp;
 261     Carp::croak $obj->name, ":", $msg, "<$pair>.", caller;
 262 }
 263
 264 1;
 265 __END__
 266
 267 =head1 NAME
 268
 269 Encode::Unicode -- Various Unicode Transformation Formats
 270
 271 =cut
 272
 273 =head1 SYNOPSIS
 274
 275     use Encode qw/encode decode/;
 276     $ucs2 = encode("UCS-2BE", $utf8);
 277     $utf8 = decode("UCS-2BE", $ucs2);
 278
 279 =head1 ABSTRACT
 280
 281 This module implements all Character Encoding Schemes of Unicode that
 282 are officially documented by Unicode Consortium (except, of course,
 283 for UTF-8, which is a native format in perl).
 284
 285 =over 4
 286
 287 =item L<http://www.unicode.org/glossary/> says:
 288
 289 I<Character Encoding Scheme> A character encoding form plus byte
 290 serialization. There are Seven character encoding schemes in Unicode:
 291 UTF-8, UTF-16, UTF-16BE, UTF-16LE, UTF-32 (UCS-4), UTF-32BE (UCS-4BE) and
 292 UTF-32LE (UCS-4LE), and UTF-7.
 293
 294 Since UTF-7 is a 7-bit (re)encoded version of UTF-16BE, It is not part of
 295 Unicode's Character Encoding Scheme.  It is separately implemented in
 296 Encode::Unicode::UTF7.  For details see L<Encode::Unicode::UTF7>.
 297
 298 =item Quick Reference
 299
 300                 Decodes from ord(N)           Encodes chr(N) to...
 301        octet/char BOM S.P d800-dfff  ord > 0xffff     \x{1abcd} ==
 302   ---------------+-----------------+------------------------------
 303   UCS-2BE       2   N   N  is bogus                  Not Available
 304   UCS-2LE       2   N   N     bogus                  Not Available
 305   UTF-16      2/4   Y   Y  is   S.P           S.P            BE/LE
 306   UTF-16BE    2/4   N   Y       S.P           S.P    0xd82a,0xdfcd
 307   UTF-16LE      2   N   Y       S.P           S.P    0x2ad8,0xcddf
 308   UTF-32        4   Y   -  is bogus         As is            BE/LE
 309   UTF-32BE      4   N   -     bogus         As is       0x0001abcd
 310   UTF-32LE      4   N   -     bogus         As is       0xcdab0100
 311   UTF-8       1-4   -   -     bogus   >= 4 octets   \xf0\x9a\af\8d
 312   ---------------+-----------------+------------------------------
 313
 314 =back
 315
 316 =head1 Size, Endianness, and BOM
 317
 318 You can categorize these CES by 3 criteria:  size of each character,
 319 endianness, and Byte Order Mark.
 320
 321 =head2 by size
 322
 323 UCS-2 is a fixed-length encoding with each character taking 16 bits.
 324 It B<does not> support I<surrogate pairs>.  When a surrogate pair
 325 is encountered during decode(), its place is filled with \x{FFFD}
 326 if I<CHECK> is 0, or the routine croaks if I<CHECK> is 1.  When a
 327 character whose ord value is larger than 0xFFFF is encountered,
 328 its place is filled with \x{FFFD} if I<CHECK> is 0, or the routine
 329 croaks if I<CHECK> is 1.
 330
 331 UTF-16 is almost the same as UCS-2 but it supports I<surrogate pairs>.
 332 When it encounters a high surrogate (0xD800-0xDBFF), it fetches the
 333 following low surrogate (0xDC00-0xDFFF) and C<desurrogate>s them to
 334 form a character.  Bogus surrogates result in death.  When \x{10000}
 335 or above is encountered during encode(), it C<ensurrogate>s them and
 336 pushes the surrogate pair to the output stream.
 337
 338 UTF-32 (UCS-4) is a fixed-length encoding with each character taking 32 bits.
 339 Since it is 32-bit, there is no need for I<surrogate pairs>.
 340
 341 =head2 by endianness
 342
 343 The first (and now failed) goal of Unicode was to map all character
 344 repertoires into a fixed-length integer so that programmers are happy.
 345 Since each character is either a I<short> or I<long> in C, you have to
 346 pay attention to the endianness of each platform when you pass data
 347 to one another.
 348
 349 Anything marked as BE is Big Endian (or network byte order) and LE is
 350 Little Endian (aka VAX byte order).  For anything not marked either
 351 BE or LE, a character called Byte Order Mark (BOM) indicating the
 352 endianness is prepended to the string.
 353
 354 =over 4
 355
 356 =item BOM as integer when fetched in network byte order
 357
 358               16         32 bits/char
 359   -------------------------
 360   BE      0xFeFF 0x0000FeFF
 361   LE      0xFFeF 0xFFFe0000
 362   -------------------------
 363
 364 =back
 365
 366 This modules handles the BOM as follows.
 367
 368 =over 4
 369
 370 =item *
 371
 372 When BE or LE is explicitly stated as the name of encoding, BOM is
 373 simply treated as a normal character (ZERO WIDTH NO-BREAK SPACE).
 374
 375 =item *
 376
 377 When BE or LE is omitted during decode(), it checks if BOM is at the
 378 beginning of the string; if one is found, the endianness is set to
 379 what the BOM says.  If no BOM is found, the routine dies.
 380
 381 =item *
 382
 383 When BE or LE is omitted during encode(), it returns a BE-encoded
 384 string with BOM prepended.  So when you want to encode a whole text
 385 file, make sure you encode() the whole text at once, not line by line
 386 or each line, not file, will have a BOM prepended.
 387
 388 =item *
 389
 390 C<UCS-2> is an exception.  Unlike others, this is an alias of UCS-2BE.
 391 UCS-2 is already registered by IANA and others that way.
 392
 393 =back
 394
 395 =head1 Surrogate Pairs
 396
 397 To say the least, surrogate pairs were the biggest mistake of the
 398 Unicode Consortium.  But according to the late Douglas Adams in I<The
 399 Hitchhiker's Guide to the Galaxy> Trilogy, C<In the beginning the
 400 Universe was created. This has made a lot of people very angry and
 401 been widely regarded as a bad move>.  Their mistake was not of this
 402 magnitude so let's forgive them.
 403
 404 (I don't dare make any comparison with Unicode Consortium and the
 405 Vogons here ;)  Or, comparing Encode to Babel Fish is completely
 406 appropriate -- if you can only stick this into your ear :)
 407
 408 Surrogate pairs were born when the Unicode Consortium finally
 409 admitted that 16 bits were not big enough to hold all the world's
 410 character repertoires.  But they already made UCS-2 16-bit.  What
 411 do we do?
 412
 413 Back then, the range 0xD800-0xDFFF was not allocated.  Let's split
 414 that range in half and use the first half to represent the C<upper
 415 half of a character> and the second half to represent the C<lower
 416 half of a character>.  That way, you can represent 1024 * 1024 =
 417 1048576 more characters.  Now we can store character ranges up to
 418 \x{10ffff} even with 16-bit encodings.  This pair of half-character is
 419 now called a I<surrogate pair> and UTF-16 is the name of the encoding
 420 that embraces them.
 421
 422 Here is a formula to ensurrogate a Unicode character \x{10000} and
 423 above;
 424
 425   $hi = ($uni - 0x10000) / 0x400 + 0xD800;
 426   $lo = ($uni - 0x10000) % 0x400 + 0xDC00;
 427
 428 And to desurrogate;
 429
 430  $uni = 0x10000 + ($hi - 0xD800) * 0x400 + ($lo - 0xDC00);
 431
 432 Note this move has made \x{D800}-\x{DFFF} into a forbidden zone but
 433 perl does not prohibit the use of characters within this range.  To perl,
 434 every one of \x{0000_0000} up to \x{ffff_ffff} (*) is I<a character>.
 435
 436   (*) or \x{ffff_ffff_ffff_ffff} if your perl is compiled with 64-bit
 437   integer support!
 438
 439 =head1 SEE ALSO
 440
 441 L<Encode>, L<Encode::Unicode::UTF7>, L<http://www.unicode.org/glossary/>,
 442 L<http://www.unicode.org/unicode/faq/utf_bom.html>,
 443
 444 RFC 2781 L<http://rfc.net/rfc2781.html>,
 445
 446 The whole Unicode standard L<http://www.unicode.org/unicode/uni2book/u2.html>
 447
 448 Ch. 15, pp. 403 of C<Programming Perl (3rd Edition)>
 449 by Larry Wall, Tom Christiansen, Jon Orwant;
 450 O'Reilly & Associates; ISBN 0-596-00027-8
 451
 452 =cut