3 use Encode qw(find_encoding);
4 use base 'Encode::Encoding';
9 Encode::Tcl - Tcl encodings
15 foreach my $dir (@INC)
17 if (opendir(my $dh,"$dir/Encode"))
19 while (defined(my $name = readdir($dh)))
21 if ($name =~ /^(.*)\.enc$/)
24 my $obj = find_encoding($canon);
27 my $obj = bless { Name => $canon, File => "$dir/Encode/$name"},__PACKAGE__;
28 $obj->Define( $canon );
29 # warn "$canon => $obj\n";
46 my $new = $obj->loadEncoding;
47 return undef unless (defined $new);
48 return $new->encode(@_);
54 my $new = $obj->loadEncoding;
55 return undef unless (defined $new);
56 return $new->new_sequence(@_);
62 my $new = $obj->loadEncoding;
63 return undef unless (defined $new);
64 return $new->decode(@_);
70 my $file = $obj->{'File'};
71 my $name = $obj->name;
72 if (open(my $fh,$file))
78 $type = substr($line,0,1);
79 last unless $type eq '#';
81 my $class = ref($obj).('::'.(($type eq 'E') ? 'Escape' : 'Table'));
84 return $obj if $obj->read($fh,$obj->name,$type);
88 croak("Cannot open $file for ".$obj->name);
90 $obj->Undefine($name);
96 my ($class,$name) = @_;
98 foreach my $dir (@INC)
100 last if ($enc = $class->loadEncoding($name,"$dir/Encode/$name.enc"));
105 package Encode::Tcl::Table;
106 use base 'Encode::Encoding';
112 my ($obj,$fh,$name,$type) = @_;
113 my $rep = $obj->can("rep_$type");
114 my ($def,$sym,$pages) = split(/\s+/,scalar(<$fh>));
123 my $page = hex($line);
125 my $ch = $page * 256;
126 for (my $i = 0; $i < 16; $i++)
129 for (my $j = 0; $j < 16; $j++)
131 my $val = hex(substr($line,0,4,''));
146 $touni[$page] = \@page;
148 $obj->{'Rep'} = $rep;
149 $obj->{'ToUni'} = \@touni;
150 $obj->{'FmUni'} = \%fmuni;
151 $obj->{'Def'} = $def;
152 $obj->{'Num'} = $count;
160 sub rep_M { ($_[0] > 255) ? 'n' : 'C' }
165 $ch = 0 unless @_ > 1;
171 my ($obj,$str,$chk) = @_;
172 my $rep = $obj->{'Rep'};
173 my $touni = $obj->{'ToUni'};
177 my $ch = ord(substr($str,0,1,''));
179 if (&$rep($ch) eq 'C')
181 $x = $touni->[0][$ch];
185 $x = $touni->[$ch][ord(substr($str,0,1,''))];
190 # What do we do here ?
195 $_[1] = $str if $chk;
202 my ($obj,$uni,$chk) = @_;
203 my $fmuni = $obj->{'FmUni'};
205 my $def = $obj->{'Def'};
206 my $rep = $obj->{'Rep'};
209 my $ch = substr($uni,0,1,'');
210 my $x = $fmuni->{chr(ord($ch))};
216 $str .= pack(&$rep($x),$x);
218 $_[1] = $uni if $chk;
222 package Encode::Tcl::Escape;
223 use base 'Encode::Encoding';
229 my ($class,$fh,$name) = @_;
230 my %self = (Name => $name, Num => 0);
233 my ($key,$val) = /^(\S+)\s+(.*)$/;
234 $val =~ s/^\{(.*?)\}/$1/g;
235 $val =~ s/\\x([0-9a-f]{2})/chr(hex($1))/ge;
238 return bless \%self,$class;
243 croak("Not implemented yet");
248 croak("Not implemented yet");