ext/Encode/lib/Encode/Tcl/Extended.pm

   1 package Encode::Tcl::Extended;
   2 use strict;
   3 our $VERSION = do {my @r=(q$Revision: 1.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r};
   4 use base 'Encode::Encoding';
   5
   6 use Carp;
   7
   8 sub read
   9 {
  10     my ($obj,$fh,$name) = @_;
  11     my(%tbl, $enc, %ssc, @key);
  12     while (<$fh>)
  13     {
  14         next unless /^(\S+)\s+(.*)$/;
  15         my ($key,$val) = ($1,$2);
  16         $val =~ s/\{(.*?)\}/$1/;
  17         $val =~ s/\\x([0-9a-f]{2})/chr(hex($1))/ge;
  18
  19         if($enc = Encode->getEncoding($key))
  20         {
  21             push @key, $val;
  22             $tbl{$val} = ref($enc) eq 'Encode::Tcl' ? $enc->loadEncoding : $enc;
  23             $ssc{$val} = substr($val,1) if $val =~ /^>/;
  24         }
  25         else
  26         {
  27             $obj->{$key} = $val;
  28         }
  29     }
  30     $obj->{'SSC'} = \%ssc; # single shift char
  31     $obj->{'Tbl'} = \%tbl; # encoding tables
  32     $obj->{'Key'} = \@key; # keys of table hash
  33     return $obj;
  34 }
  35
  36 sub decode
  37 {
  38     my ($obj,$str,$chk) = @_;
  39     my $name = $obj->{'Name'};
  40     my $tbl  = $obj->{'Tbl'};
  41     my $ssc  = $obj->{'SSC'};
  42     my $cur = ''; # current state
  43     my $uni;
  44     while (length($str))
  45     {
  46         my $cc = substr($str,0,1,'');
  47         my $ch  = ord($cc);
  48         if(!$cur && $ch > 0x7F)
  49         {
  50             $cur = '>';
  51             $cur .= $cc, next if $ssc->{$cur.$cc};
  52         }
  53         $ch ^= 0x80 if $cur;
  54
  55         if(ref($tbl->{$cur}) ne 'Encode::Tcl::Table')
  56         {
  57             $uni .= $tbl->{$cur}->decode($cc);
  58             $cur = '';
  59             next;
  60         }
  61         my $rep   = $tbl->{$cur}->{'Rep'};
  62         my $touni = $tbl->{$cur}->{'ToUni'};
  63         my $x;
  64         if (&$rep($ch) eq 'C')
  65         {
  66             $x = $touni->[0][$ch];
  67         }
  68         else
  69         {
  70             if(! length $str)
  71             {
  72                 $str = $cc; # split leading byte
  73                 last;
  74             }
  75             my $c2 = substr($str,0,1,'');
  76             $cc .= $c2;
  77             $x = $touni->[$ch][0x80 ^ ord($c2)];
  78         }
  79         unless (defined $x)
  80         {
  81           Encode::Tcl::no_map_in_decode($name, $cc.$str);
  82         }
  83         $uni .= $x;
  84         $cur = '';
  85     }
  86     if($chk)
  87     {
  88         $cur =~ s/>//;
  89         $_[1] = $cur ne '' ? $cur.$str : $str;
  90     }
  91     return $uni;
  92 }
  93
  94 sub encode
  95 {
  96     my ($obj,$uni,$chk) = @_;
  97     my $name = $obj->{'Name'};
  98     my $tbl = $obj->{'Tbl'};
  99     my $ssc = $obj->{'SSC'};
 100     my $key = $obj->{'Key'};
 101     my $str;
 102     my $cur;
 103
 104     while (length($uni))
 105     {
 106         my $ch = substr($uni,0,1,'');
 107         my $x;
 108         foreach my $k (@$key)
 109         {
 110             $x = ref($tbl->{$k}) ne 'Encode::Tcl::Table'
 111                 ? $k =~ /^>/
 112                     ? $tbl->{$k}->encode(chr(0x80 ^ ord $ch),1)
 113                         : $tbl->{$k}->encode($ch,1)
 114                             : $tbl->{$k}->{FmUni}->{$ch};
 115             $cur = $k, last if defined $x;
 116         }
 117         unless (defined $x)
 118         {
 119             unless($chk)
 120             {
 121               Encode::Tcl::no_map_in_encode(ord($ch), $name)
 122               }
 123             return undef;
 124         }
 125         if(ref($tbl->{$cur}) eq 'Encode::Tcl::Table')
 126         {
 127             my $def = $tbl->{$cur}->{'Def'};
 128             my $rep = $tbl->{$cur}->{'Rep'};
 129             my $r = &$rep($x);
 130             $x = pack($r,
 131                       $cur =~ /^>/
 132                       ? $r eq 'C' ? 0x80 ^ $x : 0x8080 ^ $x
 133                       : $x);
 134         }
 135         $str .= $ssc->{$cur} if defined $ssc->{$cur};
 136         $str .= $x;
 137     }
 138     $_[1] = $uni if $chk;
 139     return $str;
 140 }
 141 1;
 142 __END__
 143
 144 =head1 NAME
 145
 146 Encode::Tcl::Extended - Tcl EUC encodings
 147
 148 =head1 SYNOPSIS
 149
 150 none
 151
 152 =head1 DESCRIPTION
 153
 154 This module is used internally by Encode::Tcl
 155 and handles type X of Tcl encodings (a Perl extenstion).
 156
 157 Only F<euc-jp-0212.enc> belongs to type X.
 158 This is a variant of EUC-JP with JIS X 0212 in G3.
 159 If another Encode:: module would support the above encoding,
 160 this module should be removed.
 161
 162 =head1 SEE ALSO
 163
 164 L<Encode>
 165
 166 L<Encode::Tcl>
 167
 168 L<Encode::JP>
 169
 170 =cut