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, @leading);
 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    $leading[$page] = 1 if $page;
 126    my $ch = $page * 256;
 127    for (my $i = 0; $i < 16; $i++)
 128     {
 129      my $line = <$fh>;
 130      for (my $j = 0; $j < 16; $j++)
 131       {
 132        my $val = hex(substr($line,0,4,''));
 133        if ($val || !$ch)
 134         {
 135          my $uch = pack('U', $val); # chr($val);
 136          push(@page,$uch);
 137          $fmuni{$uch} = $ch;
 138          $count++;
 139         }
 140        else
 141         {
 142          push(@page,undef);
 143         }
 144        $ch++;
 145       }
 146     }
 147    $touni[$page] = \@page;
 148   }
 149  $rep = $type ne 'M' ? $obj->can("rep_$type") :
 150    sub { ($_[0] > 255) || $leading[$_[0]] ? 'n' : 'C'};
 151  $obj->{'Rep'}   = $rep;
 152  $obj->{'ToUni'} = \@touni;
 153  $obj->{'FmUni'} = \%fmuni;
 154  $obj->{'Def'}   = $def;
 155  $obj->{'Num'}   = $count;
 156  return $obj;
 157 }
 158
 159 sub rep_S { 'C' }
 160
 161 sub rep_D { 'n' }
 162
 163 #sub rep_M { ($_[0] > 255) ? 'n' : 'C' }
 164
 165 sub representation
 166 {
 167  my ($obj,$ch) = @_;
 168  $ch = 0 unless @_ > 1;
 169  $obj->{'Rep'}->($ch);
 170 }
 171
 172 sub decode
 173 {
 174  my ($obj,$str,$chk) = @_;
 175  my $rep   = $obj->{'Rep'};
 176  my $touni = $obj->{'ToUni'};
 177  my $uni   = '';
 178  while (length($str))
 179   {
 180    my $ch = ord(substr($str,0,1,''));
 181    my $x;
 182    if (&$rep($ch) eq 'C')
 183     {
 184      $x = $touni->[0][$ch];
 185     }
 186    else
 187     {
 188      $x = $touni->[$ch][ord(substr($str,0,1,''))];
 189     }
 190    unless (defined $x)
 191     {
 192      last if $chk;
 193      # What do we do here ?
 194      $x = '';
 195     }
 196    $uni .= $x;
 197   }
 198  $_[1] = $str if $chk;
 199  return $uni;
 200 }
 201
 202
 203 sub encode
 204 {
 205  my ($obj,$uni,$chk) = @_;
 206  my $fmuni = $obj->{'FmUni'};
 207  my $str   = '';
 208  my $def   = $obj->{'Def'};
 209  my $rep   = $obj->{'Rep'};
 210  while (length($uni))
 211   {
 212    my $ch = substr($uni,0,1,'');
 213    my $x  = $fmuni->{chr(ord($ch))};
 214    unless (defined $x)
 215     {
 216      last if ($chk);
 217      $x = $def;
 218     }
 219    $str .= pack(&$rep($x),$x);
 220   }
 221  $_[1] = $uni if $chk;
 222  return $str;
 223 }
 224
 225 package Encode::Tcl::Escape;
 226 use base 'Encode::Encoding';
 227
 228 use Carp;
 229
 230 sub read
 231 {
 232  my ($class,$fh,$name) = @_;
 233  my %self = (Name => $name, Num => 0);
 234  while (<$fh>)
 235   {
 236    my ($key,$val) = /^(\S+)\s+(.*)$/;
 237    $val =~ s/^\{(.*?)\}/$1/g;
 238    $val =~ s/\\x([0-9a-f]{2})/chr(hex($1))/ge;
 239    $self{$key} = $val;
 240   }
 241  return bless \%self,$class;
 242 }
 243
 244 sub decode
 245 {
 246  croak("Not implemented yet");
 247 }
 248
 249 sub encode
 250 {
 251  croak("Not implemented yet");
 252 }
 253
 254 1;
 255 __END__