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'));
82 # carp "Loading $file";
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'};
207 my $def = $obj->{'Def'};
208 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 ($obj,$fh,$name) = @_;
233 my(%tbl, @seq, $enc, @esc);
236 my ($key,$val) = /^(\S+)\s+(.*)$/;
237 $val =~ s/^\{(.*?)\}/$1/g;
238 $val =~ s/\\x([0-9a-f]{2})/chr(hex($1))/ge;
239 if($enc = Encode->getEncoding($key)){
240 $tbl{$val} = ref($enc) eq 'Encode::Tcl' ? $enc->loadEncoding : $enc;
245 if($val =~ /^\e(.*)/){ push(@esc, quotemeta $1) }
247 $obj->{'Seq'} = \@seq; # escape sequences
248 $obj->{'Tbl'} = \%tbl; # encoding tables
249 $obj->{'Esc'} = join('|', @esc); # regex of sequences following ESC
255 my ($obj,$str,$chk) = @_;
256 my $tbl = $obj->{'Tbl'};
257 my $seq = $obj->{'Seq'};
258 my $esc = $obj->{'Esc'};
259 my $ini = $obj->{'init'};
260 my $fin = $obj->{'final'};
264 while (length($str)){
265 my $uch = substr($str,0,1,'');
267 if($str =~ s/^($esc)//)
270 $cur = $tbl->{$esc} ? $esc :
271 ($esc eq $ini || $esc eq $fin) ? $std :
276 $str =~ s/^([\x20-\x2F]*[\x30-\x7E])//;
277 carp "unknown escape sequence: ESC $1";
281 if($uch eq "\x0e" || $uch eq "\x0f"){
282 $cur = $uch and next;
284 if(ref($tbl->{$cur}) eq 'Encode::XS'){
285 $uni .= $tbl->{$cur}->decode($uch);
289 my $rep = $tbl->{$cur}->{'Rep'};
290 my $touni = $tbl->{$cur}->{'ToUni'};
292 if (&$rep($ch) eq 'C')
294 $x = $touni->[0][$ch];
298 $x = $touni->[$ch][ord(substr($str,0,1,''))];
303 # What do we do here ?
308 $_[1] = $str if $chk;
314 my ($obj,$uni,$chk) = @_;
315 my $tbl = $obj->{'Tbl'};
316 my $seq = $obj->{'Seq'};
317 my $ini = $obj->{'init'};
318 my $fin = $obj->{'final'};
324 while (length($uni)){
325 my $ch = chr(ord(substr($uni,0,1,'')));
326 my $x = ref($tbl->{$pre}) eq 'Encode::XS'
327 ? $tbl->{$pre}->encode($ch,1)
328 : $tbl->{$pre}->{FmUni}->{$ch};
331 foreach my $e_seq (@$seq){
332 $x = ref($tbl->{$e_seq}) eq 'Encode::XS'
333 ? $tbl->{$e_seq}->encode($ch,1)
334 : $tbl->{$e_seq}->{FmUni}->{$ch};
335 $cur = $e_seq and last if defined $x;
338 if($x == 0x0d && !($ini eq '' && $fin eq '') && substr($uni,0,1) eq "\x0a")
340 $str .= $cur unless $cur eq $pre;
341 $str .= $fin."\x0d\x0a".$ini;
346 if(ref($tbl->{$cur}) eq 'Encode::XS'){
347 $str .= $cur unless $cur eq $pre;
348 $str .= $x; # "DEF" is lost
352 my $def = $tbl->{$cur}->{'Def'};
353 my $rep = $tbl->{$cur}->{'Rep'};
358 $str .= $cur unless $cur eq $pre;
359 $str .= pack(&$rep($x),$x);
362 $str .= $std unless $cur eq $std;
364 $_[1] = $uni if $chk;