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