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

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