ext/Encode/Encode/Tcl.pm

   1 package Encode::Tcl;
   2 use strict;
   3 use Encode qw(find_encoding);
   4 use base 'Encode::Encoding';
   5 use Carp;
   6
   7 =head1 NAME
   8
   9 Encode::Tcl - Tcl encodings
  10
  11 =cut
  12
  13 sub INC_search
  14 {
  15  foreach my $dir (@INC)
  16   {
  17    if (opendir(my $dh,"$dir/Encode"))
  18     {
  19      while (defined(my $name = readdir($dh)))
  20       {
  21        if ($name =~ /^(.*)\.enc$/)
  22         {
  23          my $canon = $1;
  24          my $obj = find_encoding($canon);
  25          if (!defined($obj))
  26           {
  27            my $obj = bless { Name => $canon, File => "$dir/Encode/$name"},__PACKAGE__;
  28            $obj->Define( $canon );
  29            # warn "$canon => $obj\n";
  30           }
  31         }
  32       }
  33      closedir($dh);
  34     }
  35   }
  36 }
  37
  38 sub import
  39 {
  40  INC_search();
  41 }
  42
  43 sub encode
  44 {
  45  my $obj = shift;
  46  my $new = $obj->loadEncoding;
  47  return undef unless (defined $new);
  48  return $new->encode(@_);
  49 }
  50
  51 sub new_sequence
  52 {
  53  my $obj = shift;
  54  my $new = $obj->loadEncoding;
  55  return undef unless (defined $new);
  56  return $new->new_sequence(@_);
  57 }
  58
  59 sub decode
  60 {
  61  my $obj = shift;
  62  my $new = $obj->loadEncoding;
  63  return undef unless (defined $new);
  64  return $new->decode(@_);
  65 }
  66
  67 sub loadEncoding
  68 {
  69  my $obj = shift;
  70  my $file = $obj->{'File'};
  71  my $name = $obj->name;
  72  if (open(my $fh,$file))
  73   {
  74    my $type;
  75    while (1)
  76     {
  77      my $line = <$fh>;
  78      $type = substr($line,0,1);
  79      last unless $type eq '#';
  80     }
  81    my $class = ref($obj).('::'.(
  82         ($type eq 'X') ? 'Extended' :
  83         ($type eq 'H') ? 'HanZi' :
  84         ($type eq 'E') ? 'Escape' : 'Table'
  85         ));
  86    # carp "Loading $file";
  87    bless $obj,$class;
  88    return $obj if $obj->read($fh,$obj->name,$type);
  89   }
  90  else
  91   {
  92    croak("Cannot open $file for ".$obj->name);
  93   }
  94  $obj->Undefine($name);
  95  return undef;
  96 }
  97
  98 sub INC_find
  99 {
 100  my ($class,$name) = @_;
 101  my $enc;
 102  foreach my $dir (@INC)
 103   {
 104    last if ($enc = $class->loadEncoding($name,"$dir/Encode/$name.enc"));
 105   }
 106  return $enc;
 107 }
 108
 109 package Encode::Tcl::Table;
 110 use base 'Encode::Encoding';
 111
 112 use Data::Dumper;
 113
 114 sub read
 115 {
 116  my ($obj,$fh,$name,$type) = @_;
 117  my($rep, @leading);
 118  my ($def,$sym,$pages) = split(/\s+/,scalar(<$fh>));
 119  my @touni;
 120  my %fmuni;
 121  my $count = 0;
 122  $def = hex($def);
 123  while ($pages--)
 124   {
 125    my $line = <$fh>;
 126    chomp($line);
 127    my $page = hex($line);
 128    my @page;
 129    $leading[$page] = 1 if $page;
 130    my $ch = $page * 256;
 131    for (my $i = 0; $i < 16; $i++)
 132     {
 133      my $line = <$fh>;
 134      for (my $j = 0; $j < 16; $j++)
 135       {
 136        my $val = hex(substr($line,0,4,''));
 137        if ($val || !$ch)
 138         {
 139          my $uch = pack('U', $val); # chr($val);
 140          push(@page,$uch);
 141          $fmuni{$uch} = $ch;
 142          $count++;
 143         }
 144        else
 145         {
 146          push(@page,undef);
 147         }
 148        $ch++;
 149       }
 150     }
 151    $touni[$page] = \@page;
 152   }
 153  $rep = $type ne 'M' ? $obj->can("rep_$type") :
 154    sub { ($_[0] > 255) || $leading[$_[0]] ? 'n' : 'C'};
 155  $obj->{'Rep'}   = $rep;
 156  $obj->{'ToUni'} = \@touni;
 157  $obj->{'FmUni'} = \%fmuni;
 158  $obj->{'Def'}   = $def;
 159  $obj->{'Num'}   = $count;
 160  return $obj;
 161 }
 162
 163 sub rep_S { 'C' }
 164
 165 sub rep_D { 'n' }
 166
 167 #sub rep_M { ($_[0] > 255) ? 'n' : 'C' }
 168
 169 sub representation
 170 {
 171  my ($obj,$ch) = @_;
 172  $ch = 0 unless @_ > 1;
 173  $obj->{'Rep'}->($ch);
 174 }
 175
 176 sub decode
 177 {
 178  my ($obj,$str,$chk) = @_;
 179  my $rep   = $obj->{'Rep'};
 180  my $touni = $obj->{'ToUni'};
 181  my $uni;
 182  while (length($str))
 183   {
 184    my $ch = ord(substr($str,0,1,''));
 185    my $x;
 186    if (&$rep($ch) eq 'C')
 187     {
 188      $x = $touni->[0][$ch];
 189     }
 190    else
 191     {
 192      $x = $touni->[$ch][ord(substr($str,0,1,''))];
 193     }
 194    unless (defined $x)
 195     {
 196      last if $chk;
 197      # What do we do here ?
 198      $x = '';
 199     }
 200    $uni .= $x;
 201   }
 202  $_[1] = $str if $chk;
 203  return $uni;
 204 }
 205
 206
 207 sub encode
 208 {
 209  my ($obj,$uni,$chk) = @_;
 210  my $fmuni = $obj->{'FmUni'};
 211  my $def   = $obj->{'Def'};
 212  my $rep   = $obj->{'Rep'};
 213  my $str;
 214  while (length($uni))
 215   {
 216    my $ch = substr($uni,0,1,'');
 217    my $x  = $fmuni->{chr(ord($ch))};
 218    unless (defined $x)
 219     {
 220      last if ($chk);
 221      $x = $def;
 222     }
 223    $str .= pack(&$rep($x),$x);
 224   }
 225  $_[1] = $uni if $chk;
 226  return $str;
 227 }
 228
 229 package Encode::Tcl::Escape;
 230 use base 'Encode::Encoding';
 231
 232 use Carp;
 233
 234 sub read
 235 {
 236  my ($obj,$fh,$name) = @_;
 237  my(%tbl, @seq, $enc, @esc, %grp);
 238  while (<$fh>)
 239   {
 240    my ($key,$val) = /^(\S+)\s+(.*)$/;
 241    $val =~ s/^\{(.*?)\}/$1/g;
 242    $val =~ s/\\x([0-9a-f]{2})/chr(hex($1))/ge;
 243
 244    if($enc = Encode->getEncoding($key)){
 245      $tbl{$val} = ref($enc) eq 'Encode::Tcl' ? $enc->loadEncoding : $enc;
 246      push @seq, $val;
 247      $grp{$val} =
 248         $val =~ m|[(]|  ? 0 : # G0 : SI  eq "\cO"
 249         $val =~ m|[)-]| ? 1 : # G1 : SO  eq "\cN"
 250         $val =~ m|[*.]| ? 2 : # G2 : SS2 eq "\eN"
 251         $val =~ m|[+/]| ? 3 : # G3 : SS3 eq "\eO"
 252                           0;  # G0
 253    }else{
 254      $obj->{$key} = $val;
 255    }
 256    if($val =~ /^\e(.*)/){ push(@esc, quotemeta $1) }
 257   }
 258  $obj->{'Grp'} = \%grp; # graphic chars
 259  $obj->{'Seq'} = \@seq; # escape sequences
 260  $obj->{'Tbl'} = \%tbl; # encoding tables
 261  $obj->{'Esc'} = join('|', @esc); # regex of sequences following ESC
 262  return $obj;
 263 }
 264
 265 sub decode
 266 {
 267  my ($obj,$str,$chk) = @_;
 268  my $tbl = $obj->{'Tbl'};
 269  my $seq = $obj->{'Seq'};
 270  my $grp = $obj->{'Grp'};
 271  my $esc = $obj->{'Esc'};
 272  my $ini = $obj->{'init'};
 273  my $fin = $obj->{'final'};
 274  my $std = $seq->[0];
 275  my $cur = $std;
 276  my @sta = ($std, undef, undef, undef); # G0 .. G3 state
 277  my $s   = 0; # state of SO-SI.   0 (G0) or 1 (G1);
 278  my $ss  = 0; # state of SS2,SS3. 0 (G0), 2 (G2) or 3 (G3);
 279  my $uni;
 280  while (length($str)){
 281    my $uch = substr($str,0,1,'');
 282    if($uch eq "\e"){
 283     if($str =~ s/^($esc)//)
 284      {
 285       my $e = "\e$1";
 286       $sta[ $grp->{$e} ] = $e if $tbl->{$e};
 287      }
 288     # appearance of "\eN\eO" or "\eO\eN" isn't supposed.
 289     elsif($str =~ s/^N//)
 290      {
 291       $ss = 2;
 292      }
 293     elsif($str =~ s/^O//)
 294      {
 295       $ss = 3;
 296      }
 297     else
 298      {
 299       $str =~ s/^([\x20-\x2F]*[\x30-\x7E])//;
 300       carp "unknown escape sequence: ESC $1";
 301      }
 302     next;
 303    }
 304    if($uch eq "\x0e"){
 305     $s = 1; next;
 306    }
 307    if($uch eq "\x0f"){
 308     $s = 0; next;
 309    }
 310
 311    $cur = $ss ? $sta[$ss] : $sta[$s];
 312
 313    if(ref($tbl->{$cur}) eq 'Encode::XS'){
 314      $uni .= $tbl->{$cur}->decode($uch);
 315      $ss = 0;
 316      next;
 317    }
 318    my $ch    = ord($uch);
 319    my $rep   = $tbl->{$cur}->{'Rep'};
 320    my $touni = $tbl->{$cur}->{'ToUni'};
 321    my $x;
 322    if (&$rep($ch) eq 'C')
 323     {
 324      $x = $touni->[0][$ch];
 325     }
 326    else
 327     {
 328      $x = $touni->[$ch][ord(substr($str,0,1,''))];
 329     }
 330    unless (defined $x)
 331     {
 332      last if $chk;
 333      # What do we do here ?
 334      $x = '';
 335     }
 336    $uni .= $x;
 337    $ss = 0;
 338   }
 339  $_[1] = $str if $chk;
 340  return $uni;
 341 }
 342
 343 sub encode
 344 {
 345  my ($obj,$uni,$chk) = @_;
 346  my $tbl = $obj->{'Tbl'};
 347  my $seq = $obj->{'Seq'};
 348  my $grp = $obj->{'Grp'};
 349  my $ini = $obj->{'init'};
 350  my $fin = $obj->{'final'};
 351  my $std = $seq->[0];
 352  my $str = $ini;
 353  my @sta = ($std,undef,undef,undef); # G0 .. G3 state
 354  my $cur = $std;
 355  my $pG = 0; # previous G: 0 or 1.
 356  my $cG = 0; # current G: 0,1,2,3.
 357
 358  if($ini && defined $grp->{$ini})
 359   {
 360     $sta[ $grp->{$ini} ] = $ini;
 361   }
 362
 363  while (length($uni)){
 364   my $ch = substr($uni,0,1,'');
 365   my $x;
 366   foreach my $e_seq (@$seq){
 367    $x = ref($tbl->{$e_seq}) eq 'Encode::XS'
 368     ? $tbl->{$e_seq}->encode($ch,1)
 369     : $tbl->{$e_seq}->{FmUni}->{$ch};
 370    $cur = $e_seq, last if defined $x;
 371   }
 372   if(ref($tbl->{$cur}) ne 'Encode::XS')
 373    {
 374     my $def = $tbl->{$cur}->{'Def'};
 375     my $rep = $tbl->{$cur}->{'Rep'};
 376     unless (defined $x){
 377      last if ($chk);
 378      $x = $def;
 379     }
 380     $x = pack(&$rep($x),$x);
 381    }
 382   $cG   = $grp->{$cur};
 383   $str .= $sta[$cG] = $cur unless $cG < 2 && $cur eq $sta[$cG];
 384
 385   $str .= $cG == 0 && $pG == 1 ? "\cO" :
 386           $cG == 1 && $pG == 0 ? "\cN" :
 387           $cG == 2 ? "\eN" :
 388           $cG == 3 ? "\eO" : "";
 389   $str .= $x;
 390   $pG = $cG if $cG < 2;
 391  }
 392  $str .= "\cO" if $pG == 1; # back to G0
 393  $str .= $std  unless $std eq $sta[0]; # GO to ASCII
 394  $str .= $fin; # necessary?
 395  $_[1] = $uni if $chk;
 396  return $str;
 397 }
 398
 399
 400 package Encode::Tcl::Extended;
 401 use base 'Encode::Encoding';
 402
 403 use Carp;
 404
 405 sub read
 406 {
 407  my ($obj,$fh,$name) = @_;
 408  my(%tbl, $enc, %ssc, @key);
 409  while (<$fh>)
 410   {
 411    my ($key,$val) = /^(\S+)\s+(.*)$/;
 412    $val =~ s/\{(.*?)\}/$1/;
 413    $val =~ s/\\x([0-9a-f]{2})/chr(hex($1))/ge;
 414
 415    if($enc = Encode->getEncoding($key)){
 416      push @key, $val;
 417      $tbl{$val} = ref($enc) eq 'Encode::Tcl'
 418         ? $enc->loadEncoding : $enc;
 419      $ssc{$val} = substr($val,1) if $val =~ /^>/;
 420    }else{
 421      $obj->{$key} = $val;
 422    }
 423   }
 424  $obj->{'SSC'} = \%ssc; # single shift char
 425  $obj->{'Tbl'} = \%tbl; # encoding tables
 426  $obj->{'Key'} = \@key; # keys of table hash
 427  return $obj;
 428 }
 429
 430 sub decode
 431 {
 432  my ($obj,$str,$chk) = @_;
 433  my $tbl = $obj->{'Tbl'};
 434  my $ssc = $obj->{'SSC'};
 435  my $cur = ''; # current state
 436  my $uni;
 437  while (length($str)){
 438    my $uch = substr($str,0,1,'');
 439    my $ch  = ord($uch);
 440    if(!$cur && $ch > 0x7F)
 441     {
 442      $cur = '>';
 443      $cur .= $uch, next if $ssc->{$cur.$uch};
 444     }
 445    $ch ^= 0x80 if $cur;
 446
 447    if(ref($tbl->{$cur}) eq 'Encode::XS'){
 448      $uni .= $tbl->{$cur}->decode(chr($ch));
 449      $cur = '';
 450      next;
 451    }
 452    my $rep   = $tbl->{$cur}->{'Rep'};
 453    my $touni = $tbl->{$cur}->{'ToUni'};
 454    my $x;
 455    if (&$rep($ch) eq 'C')
 456     {
 457      $x = $touni->[0][$ch];
 458     }
 459    else
 460     {
 461      $x = $touni->[$ch][0x80 ^ ord(substr($str,0,1,''))];
 462     }
 463    unless (defined $x)
 464     {
 465      last if $chk;
 466      # What do we do here ?
 467      $x = '';
 468     }
 469    $uni .= $x;
 470    $cur = '';
 471   }
 472  $_[1] = $str if $chk;
 473  return $uni;
 474 }
 475
 476 sub encode
 477 {
 478  my ($obj,$uni,$chk) = @_;
 479  my $tbl = $obj->{'Tbl'};
 480  my $ssc = $obj->{'SSC'};
 481  my $key = $obj->{'Key'};
 482  my $str;
 483  my $cur;
 484
 485  while (length($uni)){
 486   my $ch = substr($uni,0,1,'');
 487   my $x;
 488   foreach my $k (@$key){
 489    $x = ref($tbl->{$k}) eq 'Encode::XS'
 490     ? $k =~ /^>/
 491       ? $tbl->{$k}->encode(chr(0x80 ^ ord $ch),1)
 492       : $tbl->{$k}->encode($ch,1)
 493     : $tbl->{$k}->{FmUni}->{$ch};
 494    $cur = $k, last if defined $x;
 495   }
 496   if(ref($tbl->{$cur}) ne 'Encode::XS')
 497    {
 498     my $def = $tbl->{$cur}->{'Def'};
 499     my $rep = $tbl->{$cur}->{'Rep'};
 500     unless (defined $x){
 501      last if ($chk);
 502      $x = $def;
 503     }
 504     my $r = &$rep($x);
 505     $x = pack($r,
 506       $cur =~ /^>/
 507         ? $r eq 'C' ? 0x80 ^ $x : 0x8080 ^ $x
 508         : $x);
 509    }
 510
 511   $str .= $ssc->{$cur} if defined $ssc->{$cur};
 512   $str .= $x;
 513  }
 514  $_[1] = $uni if $chk;
 515  return $str;
 516 }
 517
 518 package Encode::Tcl::HanZi;
 519 use base 'Encode::Encoding';
 520
 521 use Carp;
 522
 523 sub read
 524 {
 525  my ($obj,$fh,$name) = @_;
 526  my(%tbl, @seq, $enc);
 527  while (<$fh>)
 528   {
 529    my ($key,$val) = /^(\S+)\s+(.*)$/;
 530    $val =~ s/^\{(.*?)\}/$1/g;
 531    $val =~ s/\\x([0-9a-f]{2})/chr(hex($1))/ge;
 532    if($enc = Encode->getEncoding($key)){
 533      $tbl{$val} = ref($enc) eq 'Encode::Tcl' ? $enc->loadEncoding : $enc;
 534      push @seq, $val;
 535    }else{
 536      $obj->{$key} = $val;
 537    }
 538   }
 539  $obj->{'Seq'} = \@seq; # escape sequences
 540  $obj->{'Tbl'} = \%tbl; # encoding tables
 541  return $obj;
 542 }
 543
 544 sub decode
 545 {
 546  my ($obj,$str,$chk) = @_;
 547  my $tbl = $obj->{'Tbl'};
 548  my $seq = $obj->{'Seq'};
 549  my $std = $seq->[0];
 550  my $cur = $std;
 551  my $uni;
 552  while (length($str)){
 553    my $uch = substr($str,0,1,'');
 554    if($uch eq "~"){
 555     if($str =~ s/^\cJ//)
 556      {
 557       next;
 558      }
 559     elsif($str =~ s/^\~//)
 560      {
 561       1;
 562      }
 563     elsif($str =~ s/^([{}])//)
 564      {
 565       $cur = "~$1";
 566       next;
 567      }
 568     else
 569      {
 570       $str =~ s/^([^~])//;
 571       carp "unknown HanZi escape sequence: ~$1";
 572       next;
 573      }
 574    }
 575    if(ref($tbl->{$cur}) eq 'Encode::XS'){
 576      $uni .= $tbl->{$cur}->decode($uch);
 577      next;
 578    }
 579    my $ch    = ord($uch);
 580    my $rep   = $tbl->{$cur}->{'Rep'};
 581    my $touni = $tbl->{$cur}->{'ToUni'};
 582    my $x;
 583    if (&$rep($ch) eq 'C')
 584     {
 585      $x = $touni->[0][$ch];
 586     }
 587    else
 588     {
 589      $x = $touni->[$ch][ord(substr($str,0,1,''))];
 590     }
 591    unless (defined $x)
 592     {
 593      last if $chk;
 594      # What do we do here ?
 595      $x = '';
 596     }
 597    $uni .= $x;
 598   }
 599  $_[1] = $str if $chk;
 600  return $uni;
 601 }
 602
 603 sub encode
 604 {
 605  my ($obj,$uni,$chk) = @_;
 606  my $tbl = $obj->{'Tbl'};
 607  my $seq = $obj->{'Seq'};
 608  my $std = $seq->[0];
 609  my $str;
 610  my $pre = $std;
 611  my $cur = $pre;
 612
 613  while (length($uni)){
 614   my $ch = chr(ord(substr($uni,0,1,'')));
 615   my $x;
 616   foreach my $e_seq (@$seq){
 617    $x = ref($tbl->{$e_seq}) eq 'Encode::XS'
 618     ? $tbl->{$e_seq}->encode($ch,1)
 619     : $tbl->{$e_seq}->{FmUni}->{$ch};
 620    $cur = $e_seq and last if defined $x;
 621   }
 622   if(ref($tbl->{$cur}) ne 'Encode::XS')
 623    {
 624     my $def = $tbl->{$cur}->{'Def'};
 625     my $rep = $tbl->{$cur}->{'Rep'};
 626     unless (defined $x){
 627      last if ($chk);
 628      $x = $def;
 629     }
 630     $x = pack(&$rep($x),$x);
 631    }
 632   $str .= $cur eq $pre ? $x : ($pre = $cur).$x;
 633   $str .= '~' if $x eq '~'; # to '~~'
 634  }
 635  $str .= $std unless $cur eq $std;
 636  $_[1] = $uni if $chk;
 637  return $str;
 638 }
 639
 640 1;
 641 __END__