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) = @_;
114 my ($def,$sym,$pages) = split(/\s+/,scalar(<$fh>));
123 my $page = hex($line);
125 $leading[$page] = 1 if $page;
126 my $ch = $page * 256;
127 for (my $i = 0; $i < 16; $i++)
130 for (my $j = 0; $j < 16; $j++)
132 my $val = hex(substr($line,0,4,''));
135 my $uch = pack('U', $val); # chr($val);
147 $touni[$page] = \@page;
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;
163 #sub rep_M { ($_[0] > 255) ? 'n' : 'C' }
168 $ch = 0 unless @_ > 1;
169 $obj->{'Rep'}->($ch);
174 my ($obj,$str,$chk) = @_;
175 my $rep = $obj->{'Rep'};
176 my $touni = $obj->{'ToUni'};
180 my $ch = ord(substr($str,0,1,''));
182 if (&$rep($ch) eq 'C')
184 $x = $touni->[0][$ch];
188 $x = $touni->[$ch][ord(substr($str,0,1,''))];
193 # What do we do here ?
198 $_[1] = $str if $chk;
205 my ($obj,$uni,$chk) = @_;
206 my $fmuni = $obj->{'FmUni'};
208 my $def = $obj->{'Def'};
209 my $rep = $obj->{'Rep'};
212 my $ch = substr($uni,0,1,'');
213 my $x = $fmuni->{chr(ord($ch))};
219 $str .= pack(&$rep($x),$x);
221 $_[1] = $uni if $chk;
225 package Encode::Tcl::Escape;
226 use base 'Encode::Encoding';
232 my ($class,$fh,$name) = @_;
233 my %self = (Name => $name, Num => 0);
236 my ($key,$val) = /^(\S+)\s+(.*)$/;
237 $val =~ s/^\{(.*?)\}/$1/g;
238 $val =~ s/\\x([0-9a-f]{2})/chr(hex($1))/ge;
241 return bless \%self,$class;
246 croak("Not implemented yet");
251 croak("Not implemented yet");