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
   8 sub INC_search
   9 {
  10  foreach my $dir (@INC)
  11   {
  12    if (opendir(my $dh,"$dir/Encode"))
  13     {
  14      while (defined(my $name = readdir($dh)))
  15       {
  16        if ($name =~ /^(.*)\.enc$/)
  17         {
  18          my $canon = $1;
  19          my $obj = find_encoding($canon);
  20          if (!defined($obj))
  21           {
  22            my $obj = bless { Name => $canon, File => "$dir/Encode/$name"},__PACKAGE__;
  23            $obj->Define( $canon );
  24            # warn "$canon => $obj\n";
  25           }
  26         }
  27       }
  28      closedir($dh);
  29     }
  30   }
  31 }
  32
  33 sub import
  34 {
  35  INC_search();
  36 }
  37
  38 sub encode
  39 {
  40  my $obj = shift;
  41  my $new = $obj->loadEncoding;
  42  return undef unless (defined $new);
  43  return $new->encode(@_);
  44 }
  45
  46 sub new_sequence
  47 {
  48  my $obj = shift;
  49  my $new = $obj->loadEncoding;
  50  return undef unless (defined $new);
  51  return $new->new_sequence(@_);
  52 }
  53
  54 sub decode
  55 {
  56  my $obj = shift;
  57  my $new = $obj->loadEncoding;
  58  return undef unless (defined $new);
  59  return $new->decode(@_);
  60 }
  61
  62 sub loadEncoding
  63 {
  64  my $obj = shift;
  65  my $file = $obj->{'File'};
  66  my $name = $obj->name;
  67  if (open(my $fh,$file))
  68   {
  69    my $type;
  70    while (1)
  71     {
  72      my $line = <$fh>;
  73      $type = substr($line,0,1);
  74      last unless $type eq '#';
  75     }
  76    my $class = ref($obj).('::'.(($type eq 'E') ? 'Escape' : 'Table'));
  77    carp "Loading $file";
  78    bless $obj,$class;
  79    return $obj if $obj->read($fh,$obj->name,$type);
  80   }
  81  else
  82   {
  83    croak("Cannot open $file for ".$obj->name);
  84   }
  85  $obj->Undefine($name);
  86  return undef;
  87 }
  88
  89 sub INC_find
  90 {
  91  my ($class,$name) = @_;
  92  my $enc;
  93  foreach my $dir (@INC)
  94   {
  95    last if ($enc = $class->loadEncoding($name,"$dir/Encode/$name.enc"));
  96   }
  97  return $enc;
  98 }
  99
 100 package Encode::Tcl::Table;
 101 use base 'Encode::Encoding';
 102
 103 use Data::Dumper;
 104
 105 sub read
 106 {
 107  my ($obj,$fh,$name,$type) = @_;
 108  my $rep = $obj->can("rep_$type");
 109  my ($def,$sym,$pages) = split(/\s+/,scalar(<$fh>));
 110  my @touni;
 111  my %fmuni;
 112  my $count = 0;
 113  $def = hex($def);
 114  while ($pages--)
 115   {
 116    my $line = <$fh>;
 117    chomp($line);
 118    my $page = hex($line);
 119    my @page;
 120    my $ch = $page * 256;
 121    for (my $i = 0; $i < 16; $i++)
 122     {
 123      my $line = <$fh>;
 124      for (my $j = 0; $j < 16; $j++)
 125       {
 126        my $val = hex(substr($line,0,4,''));
 127        if ($val || !$ch)
 128         {
 129          my $uch = chr($val);
 130          push(@page,$uch);
 131          $fmuni{$uch} = $ch;
 132          $count++;
 133         }
 134        else
 135         {
 136          push(@page,undef);
 137         }
 138        $ch++;
 139       }
 140     }
 141    $touni[$page] = \@page;
 142   }
 143  $obj->{'Rep'}   = $rep;
 144  $obj->{'ToUni'} = \@touni;
 145  $obj->{'FmUni'} = \%fmuni;
 146  $obj->{'Def'}   = $def;
 147  $obj->{'Num'}   = $count;
 148  return $obj;
 149 }
 150
 151 sub rep_S { 'C' }
 152
 153 sub rep_D { 'n' }
 154
 155 sub rep_M { ($_[0] > 255) ? 'n' : 'C' }
 156
 157 sub representation
 158 {
 159  my ($obj,$ch) = @_;
 160  $ch = 0 unless @_ > 1;
 161  $obj-{'Rep'}->($ch);
 162 }
 163
 164 sub decode
 165 {
 166  my ($obj,$str,$chk) = @_;
 167  my $rep   = $obj->{'Rep'};
 168  my $touni = $obj->{'ToUni'};
 169  my $uni   = '';
 170  while (length($str))
 171   {
 172    my $ch = ord(substr($str,0,1,''));
 173    my $x;
 174    if (&$rep($ch) eq 'C')
 175     {
 176      $x = $touni->[0][$ch];
 177     }
 178    else
 179     {
 180      $x = $touni->[$ch][ord(substr($str,0,1,''))];
 181     }
 182    unless (defined $x)
 183     {
 184      last if $chk;
 185      # What do we do here ?
 186      $x = '';
 187     }
 188    $uni .= $x;
 189   }
 190  $_[1] = $str if $chk;
 191  return $uni;
 192 }
 193
 194
 195 sub encode
 196 {
 197  my ($obj,$uni,$chk) = @_;
 198  my $fmuni = $obj->{'FmUni'};
 199  my $str   = '';
 200  my $def   = $obj->{'Def'};
 201  my $rep   = $obj->{'Rep'};
 202  while (length($uni))
 203   {
 204    my $ch = substr($uni,0,1,'');
 205    my $x  = $fmuni->{chr(ord($ch))};
 206    unless (defined $x)
 207     {
 208      last if ($chk);
 209      $x = $def;
 210     }
 211    $str .= pack(&$rep($x),$x);
 212   }
 213  $_[1] = $uni if $chk;
 214  return $str;
 215 }
 216
 217 package Encode::Tcl::Escape;
 218 use base 'Encode::Encoding';
 219
 220 use Carp;
 221
 222 sub read
 223 {
 224  my ($class,$fh,$name) = @_;
 225  my %self = (Name => $name, Num => 0);
 226  while (<$fh>)
 227   {
 228    my ($key,$val) = /^(\S+)\s+(.*)$/;
 229    $val =~ s/^\{(.*?)\}/$1/g;
 230    $val =~ s/\\x([0-9a-f]{2})/chr(hex($1))/ge;
 231    $self{$key} = $val;
 232   }
 233  return bless \%self,$class;
 234 }
 235
 236 sub decode
 237 {
 238  croak("Not implemented yet");
 239 }
 240
 241 sub encode
 242 {
 243  croak("Not implemented yet");
 244 }
 245
 246 1;
 247 __END__