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 sub from_to
 328 {
 329  my ($string,$from,$to,$check) = @_;
 330  my $f = __PACKAGE__->getEncoding($from);
 331  my $t = __PACKAGE__->getEncoding($to);
 332  my $uni = $f->toUnicode($string,$check);
 333  $string = $t->fromUnicode($uni,$check);
 334  return length($_[0] = $string);
 335 }
 336
 337 sub encodings
 338 {
 339  my ($class) = @_;
 340  my ($dir) = __FILE__ =~ /^(.*)\.pm$/;
 341  my @names = ('Unicode');
 342  if (opendir(my $dh,$dir))
 343   {
 344    while (defined(my $name = readdir($dh)))
 345     {
 346      push(@names,$1) if ($name =~ /^(.*)\.enc$/);
 347     }
 348    closedir($dh);
 349   }
 350  else
 351   {
 352    die "Cannot open $dir:$!";
 353   }
 354  return @names;
 355 }
 356
 357 my %encoding = ( Unicode => 'Encode::Unicode' );
 358
 359 sub getEncoding
 360 {
 361  my ($class,$name) = @_;
 362  unless (exists $encoding{$name})
 363   {
 364    my $file = __FILE__;
 365    $file =~ s#\.pm$#/$name.enc#;
 366    if (open(my $fh,$file))
 367     {
 368      my $type;
 369      while (1)
 370       {
 371        my $line = <$fh>;
 372        $type = substr($line,0,1);
 373        last unless $type eq '#';
 374       }
 375      $class .= ('::'.(($type eq 'E') ? 'Escape' : 'Table'));
 376      $encoding{$name} = $class->read($fh,$name,$type);
 377     }
 378   }
 379  return $encoding{$name} if exists $encoding{$name};
 380 }
 381
 382 package Encode::Unicode;
 383
 384 # Dummy package that provides the encode interface
 385
 386 sub name { 'Unicode' }
 387
 388 sub toUnicode   { $_[1] }
 389
 390 sub fromUnicode { $_[1] }
 391
 392 package Encode::Table;
 393
 394 sub read
 395 {
 396  my ($class,$fh,$name,$type) = @_;
 397  my $rep = $class->can("rep_$type");
 398  my ($def,$sym,$pages) = split(/\s+/,scalar(<$fh>));
 399  my @touni;
 400  my %fmuni;
 401  my $count = 0;
 402  $def = hex($def);
 403  $def = pack(&$rep($def),$def);
 404  while ($pages--)
 405   {
 406    my $page = hex(<$fh>);
 407    my @page;
 408    my $ch = $page * 256;
 409    for (my $i = 0; $i < 16; $i++)
 410     {
 411      my $line = <$fh>;
 412      for (my $j = 0; $j < 16; $j++)
 413       {
 414        my $val = hex(substr($line,0,4,''));
 415        if ($val || !$ch)
 416         {
 417          my $uch = chr($val);
 418          push(@page,$uch);
 419          $fmuni{$uch} = pack(&$rep($ch),$ch);
 420          $count++;
 421         }
 422        else
 423         {
 424          push(@page,undef);
 425         }
 426        $ch++;
 427       }
 428     }
 429    $touni[$page] = \@page;
 430   }
 431
 432  return bless {Name  => $name,
 433                Rep   => $rep,
 434                ToUni => \@touni,
 435                FmUni => \%fmuni,
 436                Def   => $def,
 437                Num   => $count,
 438               },$class;
 439 }
 440
 441 sub name { shift->{'Name'} }
 442
 443 sub rep_S { 'C' }
 444
 445 sub rep_D { 'S' }
 446
 447 sub rep_M { ($_[0] > 255) ? 'S' : 'C' }
 448
 449 sub representation
 450 {
 451  my ($obj,$ch) = @_;
 452  $ch = 0 unless @_ > 1;
 453  $obj-{'Rep'}->($ch);
 454 }
 455
 456 sub toUnicode
 457 {
 458  my ($obj,$str) = @_;
 459  my $rep   = $obj->{'Rep'};
 460  my $touni = $obj->{'ToUni'};
 461  my $uni   = '';
 462  while (length($str))
 463   {
 464    my $ch = ord(substr($str,0,1,''));
 465    if (&$rep($ch) eq 'C')
 466     {
 467      $uni .= $touni->[0][$ch];
 468     }
 469    else
 470     {
 471      $uni .= $touni->[$ch][ord(substr($str,0,1,''))];
 472     }
 473   }
 474  return $uni;
 475 }
 476
 477 sub fromUnicode
 478 {
 479  my ($obj,$uni) = @_;
 480  my $fmuni = $obj->{'FmUni'};
 481  my $str   = '';
 482  my $def   = $obj->{'Def'};
 483  while (length($uni))
 484   {
 485    my $ch = substr($uni,0,1,'');
 486    my $x  = $fmuni->{$ch};
 487    $x = $def unless defined $x;
 488    $str  .= $x;
 489   }
 490  return $str;
 491 }
 492
 493 package Encode::Escape;
 494 use Carp;
 495
 496 sub read
 497 {
 498  my ($class,$fh,$name) = @_;
 499  my %self = (Name => $name, Num => 0);
 500  while (<$fh>)
 501   {
 502    my ($key,$val) = /^(\S+)\s+(.*)$/;
 503    $val =~ s/^\{(.*?)\}/$1/g;
 504    $val =~ s/\\x([0-9a-f]{2})/chr(hex($1))/ge;
 505    $self{$key} = $val;
 506   }
 507  return bless \%self,$class;
 508 }
 509
 510 sub name { shift->{'Name'} }
 511
 512 sub toUnicode
 513 {
 514  croak("Not implemented yet");
 515 }
 516
 517 sub fromUnicode
 518 {
 519  croak("Not implemented yet");
 520 }
 521
 522 1;
 523
 524 __END__