ext/Encode/Encode.pm

   1 package Encode;
   2
   3 $VERSION = 0.01;
   4
   5 require DynaLoader;
   6 require Exporter;
   7
   8 @ISA = qw(Exporter DynaLoader);
   9
  10 @EXPORT_OK =
  11     qw(
  12        bytes_to_utf8
  13        utf8_to_bytes
  14        chars_to_utf8
  15        utf8_to_chars
  16        utf8_to_chars_check
  17        bytes_to_chars
  18        chars_to_bytes
  19        from_to
  20        is_utf8
  21        on_utf8
  22        off_utf8
  23        utf_to_utf
  24        encodings
  25       );
  26
  27 bootstrap Encode ();
  28
  29 =pod
  30
  31 =head1 NAME
  32
  33 Encode - character encodings
  34
  35 =head2 TERMINOLOGY
  36
  37 =over
  38
  39 =item *
  40
  41 I<char>: a character in the range 0..maxint (at least 2**32-1)
  42
  43 =item *
  44
  45 I<byte>: a character in the range 0..255
  46
  47 =back
  48
  49 The marker [INTERNAL] marks Internal Implementation Details, in
  50 general meant only for those who think they know what they are doing,
  51 and such details may change in future releases.
  52
  53 =head2 bytes
  54
  55 =over 4
  56
  57 =item *
  58
  59         bytes_to_utf8(STRING [, FROM])
  60
  61 The bytes in STRING are recoded in-place into UTF-8.  If no FROM is
  62 specified the bytes are expected to be encoded in US-ASCII or ISO
  63 8859-1 (Latin 1).  Returns the new size of STRING, or C<undef> if
  64 there's a failure.
  65
  66 [INTERNAL] Also the UTF-8 flag of STRING is turned on.
  67
  68 =item *
  69
  70         utf8_to_bytes(STRING [, TO [, CHECK]])
  71
  72 The UTF-8 in STRING is decoded in-place into bytes.  If no TO encoding
  73 is specified the bytes are expected to be encoded in US-ASCII or ISO
  74 8859-1 (Latin 1).  Returns the new size of STRING, or C<undef> if
  75 there's a failure.
  76
  77 What if there are characters > 255?  What if the UTF-8 in STRING is
  78 malformed?  See L</"Handling Malformed Data">.
  79
  80 [INTERNAL] The UTF-8 flag of STRING is not checked.
  81
  82 =back
  83
  84 =head2 chars
  85
  86 =over 4
  87
  88 =item *
  89
  90         chars_to_utf8(STRING)
  91
  92 The chars in STRING are encoded in-place into UTF-8.  Returns the new
  93 size of STRING, or C<undef> if there's a failure.
  94
  95 No assumptions are made on the encoding of the chars.  If you want to
  96 assume that the chars are Unicode and to trap illegal Unicode
  97 characters, you must use C<from_to('Unicode', ...)>.
  98
  99 [INTERNAL] Also the UTF-8 flag of STRING is turned on.
 100
 101 =over 4
 102
 103 =item *
 104
 105         utf8_to_chars(STRING)
 106
 107 The UTF-8 in STRING is decoded in-place into chars.  Returns the new
 108 size of STRING, or C<undef> if there's a failure.
 109
 110 If the UTF-8 in STRING is malformed C<undef> is returned, and also an
 111 optional lexical warning (category utf8) is given.
 112
 113 [INTERNAL] The UTF-8 flag of STRING is not checked.
 114
 115 =item *
 116
 117         utf8_to_chars_check(STRING [, CHECK])
 118
 119 (Note that special naming of this interface since a two-argument
 120 utf8_to_chars() has different semantics.)
 121
 122 The UTF-8 in STRING is decoded in-place into chars.  Returns the new
 123 size of STRING, or C<undef> if there is a failure.
 124
 125 If the UTF-8 in STRING is malformed?  See L</"Handling Malformed Data">.
 126
 127 [INTERNAL] The UTF-8 flag of STRING is not checked.
 128
 129 =back
 130
 131 =head2 chars With Encoding
 132
 133 =over 4
 134
 135 =item *
 136
 137         chars_to_utf8(STRING, FROM [, CHECK])
 138
 139 The chars in STRING encoded in FROM are recoded in-place into UTF-8.
 140 Returns the new size of STRING, or C<undef> if there's a failure.
 141
 142 No assumptions are made on the encoding of the chars.  If you want to
 143 assume that the chars are Unicode and to trap illegal Unicode
 144 characters, you must use C<from_to('Unicode', ...)>.
 145
 146 [INTERNAL] Also the UTF-8 flag of STRING is turned on.
 147
 148 =item *
 149
 150         utf8_to_chars(STRING, TO [, CHECK])
 151
 152 The UTF-8 in STRING is decoded in-place into chars encoded in TO.
 153 Returns the new size of STRING, or C<undef> if there's a failure.
 154
 155 If the UTF-8 in STRING is malformed?  See L</"Handling Malformed Data">.
 156
 157 [INTERNAL] The UTF-8 flag of STRING is not checked.
 158
 159 =item *
 160
 161         bytes_to_chars(STRING, FROM [, CHECK])
 162
 163 The bytes in STRING encoded in FROM are recoded in-place into chars.
 164 Returns the new size of STRING in bytes, or C<undef> if there's a
 165 failure.
 166
 167 If the mapping is impossible?  See L</"Handling Malformed Data">.
 168
 169 =item *
 170
 171         chars_to_bytes(STRING, TO [, CHECK])
 172
 173 The chars in STRING are recoded in-place to bytes encoded in TO.
 174 Returns the new size of STRING in bytes, or C<undef> if there's a
 175 failure.
 176
 177 If the mapping is impossible?  See L</"Handling Malformed Data">.
 178
 179 =item *
 180
 181         from_to(STRING, FROM, TO [, CHECK])
 182
 183 The chars in STRING encoded in FROM are recoded in-place into TO.
 184 Returns the new size of STRING, or C<undef> if there's a failure.
 185
 186 If mapping between the encodings is impossible?
 187 See L</"Handling Malformed Data">.
 188
 189 [INTERNAL] If TO is UTF-8, also the UTF-8 flag of STRING is turned on.
 190
 191 =back
 192
 193 =head2 Testing For UTF-8
 194
 195 =over 4
 196
 197 =item *
 198
 199         is_utf8(STRING [, CHECK])
 200
 201 [INTERNAL] Test whether the UTF-8 flag is turned on in the STRING.
 202 If CHECK is true, also checks the data in STRING for being
 203 well-formed UTF-8.  Returns true if successful, false otherwise.
 204
 205 =back
 206
 207 =head2 Toggling UTF-8-ness
 208
 209 =over 4
 210
 211 =item *
 212
 213         on_utf8(STRING)
 214
 215 [INTERNAL] Turn on the UTF-8 flag in STRING.  The data in STRING is
 216 B<not> checked for being well-formed UTF-8.  Do not use unless you
 217 B<know> that the STRING is well-formed UTF-8.  Returns the previous
 218 state of the UTF-8 flag (so please don't test the return value as
 219 I<not> success or failure), or C<undef> if STRING is not a string.
 220
 221 =item *
 222
 223         off_utf8(STRING)
 224
 225 [INTERNAL] Turn off the UTF-8 flag in STRING.  Do not use frivolously.
 226 Returns the previous state of the UTF-8 flag (so please don't test the
 227 return value as I<not> success or failure), or C<undef> if STRING is
 228 not a string.
 229
 230 =back
 231
 232 =head2 UTF-16 and UTF-32 Encodings
 233
 234 =over 4
 235
 236 =item *
 237
 238         utf_to_utf(STRING, FROM, TO [, CHECK])
 239
 240 The data in STRING is converted from Unicode Transfer Encoding FROM to
 241 Unicode Transfer Encoding TO.  Both FROM and TO may be any of the
 242 following tags (case-insensitive, with or without 'utf' or 'utf-' prefix):
 243
 244         tag             meaning
 245
 246         '7'             UTF-7
 247         '8'             UTF-8
 248         '16be'          UTF-16 big-endian
 249         '16le'          UTF-16 little-endian
 250         '16'            UTF-16 native-endian
 251         '32be'          UTF-32 big-endian
 252         '32le'          UTF-32 little-endian
 253         '32'            UTF-32 native-endian
 254
 255 UTF-16 is also known as UCS-2, 16 bit or 2-byte chunks, and UTF-32 as
 256 UCS-4, 32-bit or 4-byte chunks.  Returns the new size of STRING, or
 257 C<undef> is there's a failure.
 258
 259 If FROM is UTF-8 and the UTF-8 in STRING is malformed?  See
 260 L</"Handling Malformed Data">.
 261
 262 [INTERNAL] Even if CHECK is true and FROM is UTF-8, the UTF-8 flag of
 263 STRING is not checked.  If TO is UTF-8, also the UTF-8 flag of STRING is
 264 turned on.  Identical FROM and TO are fine.
 265
 266 =back
 267
 268 =head2 Handling Malformed Data
 269
 270 If CHECK is not set, C<undef> is returned.  If the data is supposed to
 271 be UTF-8, an optional lexical warning (category utf8) is given.  If
 272 CHECK is true but not a code reference, dies.  If CHECK is a code
 273 reference, it is called with the arguments
 274
 275         (MALFORMED_STRING, STRING_FROM_SO_FAR, STRING_TO_SO_FAR)
 276
 277 Two return values are expected from the call: the string to be used in
 278 the result string in place of the malformed section, and the length of
 279 the malformed section in bytes.
 280
 281 =cut
 282
 283 sub bytes_to_utf8 {
 284     &_bytes_to_utf8;
 285 }
 286
 287 sub utf8_to_bytes {
 288     &_utf8_to_bytes;
 289 }
 290
 291 sub chars_to_utf8 {
 292     &C_to_utf8;
 293 }
 294
 295 sub utf8_to_chars {
 296     &_utf8_to_chars;
 297 }
 298
 299 sub utf8_to_chars_check {
 300     &_utf8_to_chars_check;
 301 }
 302
 303 sub bytes_to_chars {
 304     &_bytes_to_chars;
 305 }
 306
 307 sub chars_to_bytes {
 308     &_chars_to_bytes;
 309 }
 310
 311 sub is_utf8 {
 312     &_is_utf8;
 313 }
 314
 315 sub on_utf8 {
 316     &_on_utf8;
 317 }
 318
 319 sub off_utf8 {
 320     &_off_utf8;
 321 }
 322
 323 sub utf_to_utf {
 324     &_utf_to_utf;
 325 }
 326
 327 use Carp;
 328
 329 sub from_to
 330 {
 331  my ($string,$from,$to,$check) = @_;
 332  my $f = __PACKAGE__->getEncoding($from);
 333  croak("Unknown encoding '$from'") unless $f;
 334  my $t = __PACKAGE__->getEncoding($to);
 335  croak("Unknown encoding '$to'") unless $t;
 336  my $uni = $f->toUnicode($string,$check);
 337  return undef if ($check && length($string));
 338  $string = $t->fromUnicode($uni,$check);
 339  return undef if ($check && length($uni));
 340  return length($_[0] = $string);
 341 }
 342
 343 sub encodings
 344 {
 345  my ($class) = @_;
 346  my ($dir) = __FILE__ =~ /^(.*)\.pm$/;
 347  my @names = ('Unicode');
 348  if (opendir(my $dh,$dir))
 349   {
 350    while (defined(my $name = readdir($dh)))
 351     {
 352      push(@names,$1) if ($name =~ /^(.*)\.enc$/);
 353     }
 354    closedir($dh);
 355   }
 356  else
 357   {
 358    die "Cannot open $dir:$!";
 359   }
 360  return @names;
 361 }
 362
 363 my %encoding = ( Unicode      => bless({},'Encode::Unicode'),
 364                  'iso10646-1' => bless({},'Encode::iso10646_1'),
 365                );
 366
 367 sub getEncoding
 368 {
 369  my ($class,$name) = @_;
 370  unless (exists $encoding{$name})
 371   {
 372    my $file;
 373    foreach my $dir (@INC)
 374     {
 375      last if -f ($file = "$dir/Encode/$name.enc");
 376     }
 377    if (open(my $fh,$file))
 378     {
 379      my $type;
 380      while (1)
 381       {
 382        my $line = <$fh>;
 383        $type = substr($line,0,1);
 384        last unless $type eq '#';
 385       }
 386      $class .= ('::'.(($type eq 'E') ? 'Escape' : 'Table'));
 387      $encoding{$name} = $class->read($fh,$name,$type);
 388     }
 389    else
 390     {
 391      $encoding{$name} = undef;
 392     }
 393   }
 394  return $encoding{$name};
 395 }
 396
 397 package Encode::Unicode;
 398
 399 # Dummy package that provides the encode interface
 400
 401 sub name { 'Unicode' }
 402
 403 sub toUnicode   { $_[1] }
 404
 405 sub fromUnicode { $_[1] }
 406
 407 package Encode::Table;
 408
 409 sub read
 410 {
 411  my ($class,$fh,$name,$type) = @_;
 412  my $rep = $class->can("rep_$type");
 413  my ($def,$sym,$pages) = split(/\s+/,scalar(<$fh>));
 414  my @touni;
 415  my %fmuni;
 416  my $count = 0;
 417  $def = hex($def);
 418  while ($pages--)
 419   {
 420    my $line = <$fh>;
 421    chomp($line);
 422    my $page = hex($line);
 423    my @page;
 424    my $ch = $page * 256;
 425    for (my $i = 0; $i < 16; $i++)
 426     {
 427      my $line = <$fh>;
 428      for (my $j = 0; $j < 16; $j++)
 429       {
 430        my $val = hex(substr($line,0,4,''));
 431        if ($val || !$ch)
 432         {
 433          my $uch = chr($val);
 434          push(@page,$uch);
 435          $fmuni{$uch} = $ch;
 436          $count++;
 437         }
 438        else
 439         {
 440          push(@page,undef);
 441         }
 442        $ch++;
 443       }
 444     }
 445    $touni[$page] = \@page;
 446   }
 447
 448  return bless {Name  => $name,
 449                Rep   => $rep,
 450                ToUni => \@touni,
 451                FmUni => \%fmuni,
 452                Def   => $def,
 453                Num   => $count,
 454               },$class;
 455 }
 456
 457 sub name { shift->{'Name'} }
 458
 459 sub rep_S { 'C' }
 460
 461 sub rep_D { 'S' }
 462
 463 sub rep_M { ($_[0] > 255) ? 'S' : 'C' }
 464
 465 sub representation
 466 {
 467  my ($obj,$ch) = @_;
 468  $ch = 0 unless @_ > 1;
 469  $obj-{'Rep'}->($ch);
 470 }
 471
 472 sub toUnicode
 473 {
 474  my ($obj,$str,$chk) = @_;
 475  my $rep   = $obj->{'Rep'};
 476  my $touni = $obj->{'ToUni'};
 477  my $uni   = '';
 478  while (length($str))
 479   {
 480    my $ch = ord(substr($str,0,1,''));
 481    my $x;
 482    if (&$rep($ch) eq 'C')
 483     {
 484      $x = $touni->[0][$ch];
 485     }
 486    else
 487     {
 488      $x = $touni->[$ch][ord(substr($str,0,1,''))];
 489     }
 490    unless (defined $x)
 491     {
 492      last if $chk;
 493      # What do we do here ?
 494      $x = '';
 495     }
 496    $uni .= $x;
 497   }
 498  $_[1] = $str if $chk;
 499  return $uni;
 500 }
 501
 502 sub fromUnicode
 503 {
 504  my ($obj,$uni,$chk) = @_;
 505  my $fmuni = $obj->{'FmUni'};
 506  my $str   = '';
 507  my $def   = $obj->{'Def'};
 508  my $rep   = $obj->{'Rep'};
 509  while (length($uni))
 510   {
 511    my $ch = substr($uni,0,1,'');
 512    my $x  = $fmuni->{$ch};
 513    unless (defined $x)
 514     {
 515      last if ($chk);
 516      $x = $def;
 517     }
 518    $str .= pack(&$rep($x),$x);
 519   }
 520  $_[1] = $uni if $chk;
 521  return $str;
 522 }
 523
 524 package Encode::iso10646_1;#
 525
 526 sub name { 'iso10646-1' }
 527
 528 sub toUnicode
 529 {
 530  my ($obj,$str,$chk) = @_;
 531  my $uni   = '';
 532  while (length($str))
 533   {
 534    my $code = unpack('S',substr($str,0,2,''));
 535    $uni .= chr($code);
 536   }
 537  $_[1] = $str if $chk;
 538  return $uni;
 539 }
 540
 541 sub fromUnicode
 542 {
 543  my ($obj,$uni,$chk) = @_;
 544  my $str   = '';
 545  while (length($uni))
 546   {
 547    my $ch = substr($uni,0,1,'');
 548    my $x  = ord($ch);
 549    unless ($x < 32768)
 550     {
 551      last if ($chk);
 552      $x = 0;
 553     }
 554    $str .= pack('S',$x);
 555   }
 556  $_[1] = $uni if $chk;
 557  return $str;
 558 }
 559
 560 package Encode::Escape;
 561 use Carp;
 562
 563 sub read
 564 {
 565  my ($class,$fh,$name) = @_;
 566  my %self = (Name => $name, Num => 0);
 567  while (<$fh>)
 568   {
 569    my ($key,$val) = /^(\S+)\s+(.*)$/;
 570    $val =~ s/^\{(.*?)\}/$1/g;
 571    $val =~ s/\\x([0-9a-f]{2})/chr(hex($1))/ge;
 572    $self{$key} = $val;
 573   }
 574  return bless \%self,$class;
 575 }
 576
 577 sub name { shift->{'Name'} }
 578
 579 sub toUnicode
 580 {
 581  croak("Not implemented yet");
 582 }
 583
 584 sub fromUnicode
 585 {
 586  croak("Not implemented yet");
 587 }
 588
 589 1;
 590
 591 __END__