ext/Encode/lib/Encode/Tcl/Table.pm

   1 package Encode::Tcl::Table;
   2 use strict;
   3 our $VERSION = do { my @r = (q$Revision: 0.92 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
   4
   5 use base 'Encode::Encoding';
   6
   7 use Carp;
   8 #use Data::Dumper;
   9
  10 sub read
  11 {
  12     my ($obj,$fh,$name,$type) = @_;
  13     my($rep, @leading);
  14     my ($def,$sym,$pages) = split(/\s+/,scalar(<$fh>));
  15     my @touni;
  16     my %fmuni;
  17     my $count = 0;
  18     $def = hex($def);
  19     while ($pages--)
  20     {
  21         my $line = <$fh>;
  22         chomp($line);
  23         my $page = hex($line);
  24         my @page;
  25         $leading[$page] = 1 if $page;
  26         my $ch = $page * 256;
  27         for (my $i = 0; $i < 16; $i++)
  28         {
  29             my $line = <$fh>;
  30             for (my $j = 0; $j < 16; $j++)
  31             {
  32                 my $val = hex(substr($line,0,4,''));
  33                 if ($val || !$ch)
  34                 {
  35                     my $uch = pack('U', $val); # chr($val);
  36                     push(@page,$uch);
  37                     $fmuni{$uch} = $ch;
  38                     $count++;
  39                 }
  40                 else
  41                 {
  42                     push(@page,undef);
  43                 }
  44                 $ch++;
  45             }
  46         }
  47         $touni[$page] = \@page;
  48     }
  49     $rep = $type ne 'M'
  50         ? $obj->can("rep_$type")
  51             : sub
  52             {
  53                 ($_[0] > 255) || $leading[$_[0]] ? 'n' : 'C';
  54             };
  55     $obj->{'Rep'}   = $rep;
  56     $obj->{'ToUni'} = \@touni;
  57     $obj->{'FmUni'} = \%fmuni;
  58     $obj->{'Def'}   = $def;
  59     $obj->{'Num'}   = $count;
  60     return $obj;
  61 }
  62
  63 sub rep_S { 'C' }
  64
  65 sub rep_D { 'n' }
  66
  67 #sub rep_M { ($_[0] > 255) ? 'n' : 'C' }
  68
  69 sub representation
  70 {
  71     my ($obj,$ch) = @_;
  72     $ch = 0 unless @_ > 1;
  73     $obj->{'Rep'}->($ch);
  74 }
  75
  76 sub decode
  77 {
  78     my($obj,$str,$chk) = @_;
  79     my $name  = $obj->{'Name'};
  80     my $rep   = $obj->{'Rep'};
  81     my $touni = $obj->{'ToUni'};
  82     my $uni;
  83     while (length($str))
  84     {
  85         my $cc = substr($str,0,1,'');
  86         my $ch = ord($cc);
  87         my $x;
  88         if (&$rep($ch) eq 'C')
  89         {
  90             $x = $touni->[0][$ch];
  91         }
  92         else
  93         {
  94             if(! length $str)
  95             {
  96                 $str = pack('C',$ch); # split leading byte
  97                 last;
  98             }
  99             my $c2 = substr($str,0,1,'');
 100             $cc .= $c2;
 101             $x = $touni->[$ch][ord($c2)];
 102         }
 103         unless (defined $x)
 104         {
 105           Encode::Tcl::no_map_in_decode($name, $cc.$str);
 106         }
 107         $uni .= $x;
 108     }
 109     $_[1] = $str if $chk;
 110     return $uni;
 111 }
 112
 113 sub encode
 114 {
 115     my ($obj,$uni,$chk) = @_;
 116     my $fmuni = $obj->{'FmUni'};
 117     my $def   = $obj->{'Def'};
 118     my $name  = $obj->{'Name'};
 119     my $rep   = $obj->{'Rep'};
 120     my $str;
 121     while (length($uni))
 122     {
 123         my $ch = substr($uni,0,1,'');
 124         my $x  = $fmuni->{$ch};
 125         unless(defined $x)
 126         {
 127             unless($chk)
 128             {
 129               Encode::Tcl::no_map_in_encode(ord($ch), $name)
 130               }
 131             return undef;
 132         }
 133         $str .= pack(&$rep($x),$x);
 134     }
 135     $_[1] = $uni if $chk;
 136     return $str;
 137 }
 138 1;
 139 __END__
 140
 141 =head1 NAME
 142
 143 Encode::Tcl::Table - Tcl Table encodings
 144
 145 =head1 SYNOPSIS
 146
 147 none
 148
 149 =head1 DESCRIPTION
 150
 151 This module is used internally by Encode::Tcl
 152 and handles types S, D, and M of Tcl encodings.
 153
 154 Implementation for type M is restricted to encodings
 155 in which the number of bytes per a character is up to 2.
 156
 157 =head1 SEE ALSO
 158
 159 L<Encode>
 160
 161 L<Encode::Tcl>
 162
 163 =cut