ext/Encode/lib/Encode/Tcl/HanZi.pm

   1 package Encode::Tcl::HanZi;
   2 our $VERSION = do {my @r=(q$Revision: 1.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r};
   3 use base 'Encode::Encoding';
   4
   5 use Carp;
   6
   7 sub read
   8 {
   9     my ($obj,$fh,$name) = @_;
  10     my(%tbl, @seq, $enc);
  11     while (<$fh>)
  12     {
  13         next unless /^(\S+)\s+(.*)$/;
  14         my ($key,$val) = ($1,$2);
  15         $val =~ s/^\{(.*?)\}/$1/g;
  16         $val =~ s/\\x([0-9a-f]{2})/chr(hex($1))/ge;
  17         if($enc = Encode->getEncoding($key))
  18         {
  19             $tbl{$val} = ref($enc) eq 'Encode::Tcl' ? $enc->loadEncoding : $enc;
  20             push @seq, $val;
  21         }
  22         else
  23         {
  24             $obj->{$key} = $val;
  25         }
  26     }
  27     $obj->{'Seq'} = \@seq; # escape sequences
  28     $obj->{'Tbl'} = \%tbl; # encoding tables
  29     return $obj;
  30 }
  31
  32 sub decode
  33 {
  34     my ($obj,$str,$chk) = @_;
  35     my $name = $obj->{'Name'};
  36     my $tbl = $obj->{'Tbl'};
  37     my $seq = $obj->{'Seq'};
  38     my $std = $seq->[0];
  39     my $cur = $std;
  40     my $uni;
  41     while (length($str)){
  42         my $cc = substr($str,0,1,'');
  43         if($cc eq "~")
  44         {
  45             if($str =~ s/^\cJ//)
  46             {
  47                 next;
  48             }
  49             elsif($str =~ s/^\~//)
  50             {
  51                 1; # no-op
  52             }
  53             elsif($str =~ s/^([{}])//)
  54             {
  55                 $cur = "~$1";
  56                 next;
  57             }
  58             elsif(! length $str)
  59             {
  60                 $str = '~';
  61                 last;
  62             }
  63             else
  64             {
  65                 $str =~ s/^([^~])//;
  66                 croak "unknown HanZi escape sequence: ~$1";
  67                 next;
  68             }
  69         }
  70         if(ref($tbl->{$cur}) ne 'Encode::Tcl::Table')
  71         {
  72             $uni .= $tbl->{$cur}->decode($cc);
  73             next;
  74         }
  75         my $ch    = ord($cc);
  76         my $rep   = $tbl->{$cur}->{'Rep'};
  77         my $touni = $tbl->{$cur}->{'ToUni'};
  78         my $x;
  79         if (&$rep($ch) eq 'C')
  80         {
  81             $x = $touni->[0][$ch];
  82         }
  83         else
  84         {
  85             if(! length $str)
  86             {
  87                 $str = $cc; # split leading byte
  88                 last;
  89             }
  90             my $c2 = substr($str,0,1,'');
  91             $cc .= $c2;
  92             $x = $touni->[$ch][ord($c2)];
  93         }
  94         unless (defined $x)
  95         {
  96           Encode::Tcl::no_map_in_decode($name, $cc.$str);
  97         }
  98         $uni .= $x;
  99     }
 100     if($chk)
 101     {
 102         $_[1] = $cur eq $std ? $str : $cur.$str;
 103     }
 104     return $uni;
 105 }
 106
 107 sub encode
 108 {
 109     my ($obj,$uni,$chk) = @_;
 110     my $name = $obj->{'Name'};
 111     my $tbl = $obj->{'Tbl'};
 112     my $seq = $obj->{'Seq'};
 113     my $std = $seq->[0];
 114     my $str;
 115     my $pre = $std;
 116     my $cur = $pre;
 117
 118     while (length($uni))
 119     {
 120         my $ch = substr($uni,0,1,'');
 121         my $x;
 122         foreach my $e_seq (@$seq)
 123         {
 124             $x = ref($tbl->{$e_seq}) eq 'Encode::Tcl::Table'
 125                 ? $tbl->{$e_seq}->{FmUni}->{$ch}
 126             : $tbl->{$e_seq}->encode($ch,1);
 127             $cur = $e_seq and last if defined $x;
 128         }
 129         unless (defined $x)
 130         {
 131             unless($chk)
 132             {
 133               Encode::Tcl::no_map_in_encode(ord($ch), $name)
 134               }
 135             return undef;
 136         }
 137         if(ref($tbl->{$cur}) eq 'Encode::Tcl::Table')
 138         {
 139             my $def = $tbl->{$cur}->{'Def'};
 140             my $rep = $tbl->{$cur}->{'Rep'};
 141             $x = pack(&$rep($x),$x);
 142         }
 143         $str .= $cur eq $pre ? $x : ($pre = $cur).$x;
 144         $str .= '~' if $x eq '~'; # to '~~'
 145     }
 146     $str .= $std unless $cur eq $std;
 147     $_[1] = $uni if $chk;
 148     return $str;
 149 }
 150 1;
 151 __END__