3 use Encode qw(find_encoding);
4 use base 'Encode::Encoding';
10 foreach my $dir (@INC)
12 if (opendir(my $dh,"$dir/Encode"))
14 while (defined(my $name = readdir($dh)))
16 if ($name =~ /^(.*)\.enc$/)
19 my $obj = find_encoding($canon);
22 my $obj = bless { Name => $canon, File => "$dir/Encode/$name"},__PACKAGE__;
23 $obj->Define( $canon );
24 # warn "$canon => $obj\n";
41 my $new = $obj->loadEncoding;
42 return undef unless (defined $new);
43 return $new->encode(@_);
49 my $new = $obj->loadEncoding;
50 return undef unless (defined $new);
51 return $new->new_sequence(@_);
57 my $new = $obj->loadEncoding;
58 return undef unless (defined $new);
59 return $new->decode(@_);
65 my $file = $obj->{'File'};
66 my $name = $obj->name;
67 if (open(my $fh,$file))
73 $type = substr($line,0,1);
74 last unless $type eq '#';
76 my $class = ref($obj).('::'.(($type eq 'E') ? 'Escape' : 'Table'));
79 return $obj if $obj->read($fh,$obj->name,$type);
83 croak("Cannot open $file for ".$obj->name);
85 $obj->Undefine($name);
91 my ($class,$name) = @_;
93 foreach my $dir (@INC)
95 last if ($enc = $class->loadEncoding($name,"$dir/Encode/$name.enc"));
100 package Encode::Tcl::Table;
101 use base 'Encode::Encoding';
107 my ($obj,$fh,$name,$type) = @_;
108 my $rep = $obj->can("rep_$type");
109 my ($def,$sym,$pages) = split(/\s+/,scalar(<$fh>));
118 my $page = hex($line);
120 my $ch = $page * 256;
121 for (my $i = 0; $i < 16; $i++)
124 for (my $j = 0; $j < 16; $j++)
126 my $val = hex(substr($line,0,4,''));
141 $touni[$page] = \@page;
143 $obj->{'Rep'} = $rep;
144 $obj->{'ToUni'} = \@touni;
145 $obj->{'FmUni'} = \%fmuni;
146 $obj->{'Def'} = $def;
147 $obj->{'Num'} = $count;
155 sub rep_M { ($_[0] > 255) ? 'n' : 'C' }
160 $ch = 0 unless @_ > 1;
166 my ($obj,$str,$chk) = @_;
167 my $rep = $obj->{'Rep'};
168 my $touni = $obj->{'ToUni'};
172 my $ch = ord(substr($str,0,1,''));
174 if (&$rep($ch) eq 'C')
176 $x = $touni->[0][$ch];
180 $x = $touni->[$ch][ord(substr($str,0,1,''))];
185 # What do we do here ?
190 $_[1] = $str if $chk;
197 my ($obj,$uni,$chk) = @_;
198 my $fmuni = $obj->{'FmUni'};
200 my $def = $obj->{'Def'};
201 my $rep = $obj->{'Rep'};
204 my $ch = substr($uni,0,1,'');
205 my $x = $fmuni->{chr(ord($ch))};
211 $str .= pack(&$rep($x),$x);
213 $_[1] = $uni if $chk;
217 package Encode::Tcl::Escape;
218 use base 'Encode::Encoding';
224 my ($class,$fh,$name) = @_;
225 my %self = (Name => $name, Num => 0);
228 my ($key,$val) = /^(\S+)\s+(.*)$/;
229 $val =~ s/^\{(.*?)\}/$1/g;
230 $val =~ s/\\x([0-9a-f]{2})/chr(hex($1))/ge;
233 return bless \%self,$class;
238 croak("Not implemented yet");
243 croak("Not implemented yet");