This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Remove tautology in error messages
[perl5.git] / 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__