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.36 $ =~ /\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, UTF-32BE and UTF-32LE.
 292
 293 =item Quick Reference
 294
 295                 Decodes from ord(N)           Encodes chr(N) to...
 296        octet/char BOM S.P d800-dfff  ord > 0xffff     \x{1abcd} ==
 297   ---------------+-----------------+------------------------------
 298   UCS-2BE       2   N   N  is bogus                  Not Available
 299   UCS-2LE       2   N   N     bogus                  Not Available
 300   UTF-16      2/4   Y   Y  is   S.P           S.P            BE/LE
 301   UTF-16BE    2/4   N   Y       S.P           S.P    0xd82a,0xdfcd
 302   UTF-16LE      2   N   Y       S.P           S.P    0x2ad8,0xcddf
 303   UTF-32        4   Y   -  is bogus         As is            BE/LE
 304   UTF-32BE      4   N   -     bogus         As is       0x0001abcd
 305   UTF-32LE      4   N   -     bogus         As is       0xcdab0100
 306   UTF-8       1-4   -   -     bogus   >= 4 octets   \xf0\x9a\af\8d
 307   ---------------+-----------------+------------------------------
 308
 309 =back
 310
 311 =head1 Size, Endianness, and BOM
 312
 313 You can categorize these CES by 3 criteria:  size of each character,
 314 endianness, and Byte Order Mark.
 315
 316 =head2 by size
 317
 318 UCS-2 is a fixed-length encoding with each character taking 16 bits.
 319 It B<does not> support I<surrogate pairs>.  When a surrogate pair
 320 is encountered during decode(), its place is filled with \x{FFFD}
 321 if I<CHECK> is 0, or the routine croaks if I<CHECK> is 1.  When a
 322 character whose ord value is larger than 0xFFFF is encountered,
 323 its place is filled with \x{FFFD} if I<CHECK> is 0, or the routine
 324 croaks if I<CHECK> is 1.
 325
 326 UTF-16 is almost the same as UCS-2 but it supports I<surrogate pairs>.
 327 When it encounters a high surrogate (0xD800-0xDBFF), it fetches the
 328 following low surrogate (0xDC00-0xDFFF) and C<desurrogate>s them to
 329 form a character.  Bogus surrogates result in death.  When \x{10000}
 330 or above is encountered during encode(), it C<ensurrogate>s them and
 331 pushes the surrogate pair to the output stream.
 332
 333 UTF-32 is a fixed-length encoding with each character taking 32 bits.
 334 Since it is 32-bit, there is no need for I<surrogate pairs>.
 335
 336 =head2 by endianness
 337
 338 The first (and now failed) goal of Unicode was to map all character
 339 repertoires into a fixed-length integer so that programmers are happy.
 340 Since each character is either a I<short> or I<long> in C, you have to
 341 pay attention to the endianness of each platform when you pass data
 342 to one another.
 343
 344 Anything marked as BE is Big Endian (or network byte order) and LE is
 345 Little Endian (aka VAX byte order).  For anything not marked either
 346 BE or LE, a character called Byte Order Mark (BOM) indicating the
 347 endianness is prepended to the string.
 348
 349 =over 4
 350
 351 =item BOM as integer when fetched in network byte order
 352
 353               16         32 bits/char
 354   -------------------------
 355   BE      0xFeFF 0x0000FeFF
 356   LE      0xFFeF 0xFFFe0000
 357   -------------------------
 358
 359 =back
 360
 361 This modules handles the BOM as follows.
 362
 363 =over 4
 364
 365 =item *
 366
 367 When BE or LE is explicitly stated as the name of encoding, BOM is
 368 simply treated as a normal character (ZERO WIDTH NO-BREAK SPACE).
 369
 370 =item *
 371
 372 When BE or LE is omitted during decode(), it checks if BOM is at the
 373 beginning of the string; if one is found, the endianness is set to
 374 what the BOM says.  If no BOM is found, the routine dies.
 375
 376 =item *
 377
 378 When BE or LE is omitted during encode(), it returns a BE-encoded
 379 string with BOM prepended.  So when you want to encode a whole text
 380 file, make sure you encode() the whole text at once, not line by line
 381 or each line, not file, will have a BOM prepended.
 382
 383 =item *
 384
 385 C<UCS-2> is an exception.  Unlike others, this is an alias of UCS-2BE.
 386 UCS-2 is already registered by IANA and others that way.
 387
 388 =back
 389
 390 =head1 Surrogate Pairs
 391
 392 To say the least, surrogate pairs were the biggest mistake of the
 393 Unicode Consortium.  But according to the late Douglas Adams in I<The
 394 Hitchhiker's Guide to the Galaxy> Trilogy, C<In the beginning the
 395 Universe was created. This has made a lot of people very angry and
 396 been widely regarded as a bad move>.  Their mistake was not of this
 397 magnitude so let's forgive them.
 398
 399 (I don't dare make any comparison with Unicode Consortium and the
 400 Vogons here ;)  Or, comparing Encode to Babel Fish is completely
 401 appropriate -- if you can only stick this into your ear :)
 402
 403 Surrogate pairs were born when the Unicode Consortium finally
 404 admitted that 16 bits were not big enough to hold all the world's
 405 character repertoires.  But they already made UCS-2 16-bit.  What
 406 do we do?
 407
 408 Back then, the range 0xD800-0xDFFF was not allocated.  Let's split
 409 that range in half and use the first half to represent the C<upper
 410 half of a character> and the second half to represent the C<lower
 411 half of a character>.  That way, you can represent 1024 * 1024 =
 412 1048576 more characters.  Now we can store character ranges up to
 413 \x{10ffff} even with 16-bit encodings.  This pair of half-character is
 414 now called a I<surrogate pair> and UTF-16 is the name of the encoding
 415 that embraces them.
 416
 417 Here is a formula to ensurrogate a Unicode character \x{10000} and
 418 above;
 419
 420   $hi = ($uni - 0x10000) / 0x400 + 0xD800;
 421   $lo = ($uni - 0x10000) % 0x400 + 0xDC00;
 422
 423 And to desurrogate;
 424
 425  $uni = 0x10000 + ($hi - 0xD800) * 0x400 + ($lo - 0xDC00);
 426
 427 Note this move has made \x{D800}-\x{DFFF} into a forbidden zone but
 428 perl does not prohibit the use of characters within this range.  To perl,
 429 every one of \x{0000_0000} up to \x{ffff_ffff} (*) is I<a character>.
 430
 431   (*) or \x{ffff_ffff_ffff_ffff} if your perl is compiled with 64-bit
 432   integer support!
 433
 434 =head1 SEE ALSO
 435
 436 L<Encode>, L<http://www.unicode.org/glossary/>,
 437
 438 RFC 2781 L<http://rfc.net/rfc2781.html>,
 439
 440 L<http://www.unicode.org/unicode/faq/utf_bom.html>
 441
 442 Ch. 15, pp. 403 of C<Programming Perl (3rd Edition)>
 443 by Larry Wall, Tom Christiansen, Jon Orwant;
 444 O'Reilly & Associates; ISBN 0-596-00027-8
 445
 446 =cut