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 'H') ? 'HanZi' : ($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,'')));
327 foreach my $e_seq ($std, $pre, @$seq){
328 $x = ref($tbl->{$e_seq}) eq 'Encode::XS'
329 ? $tbl->{$e_seq}->encode($ch,1)
330 : $tbl->{$e_seq}->{FmUni}->{$ch};
331 $cur = $e_seq and last if defined $x;
333 if(ref($tbl->{$cur}) ne 'Encode::XS')
335 my $def = $tbl->{$cur}->{'Def'};
336 my $rep = $tbl->{$cur}->{'Rep'};
341 $x = pack(&$rep($x),$x);
343 $str .= $cur eq $pre ? $x : ($pre = $cur).$x;
345 $str .= $std unless $cur eq $std;
347 $_[1] = $uni if $chk;
351 package Encode::Tcl::HanZi;
352 use base 'Encode::Encoding';
358 my ($obj,$fh,$name) = @_;
359 my(%tbl, @seq, $enc);
362 my ($key,$val) = /^(\S+)\s+(.*)$/;
363 $val =~ s/^\{(.*?)\}/$1/g;
364 $val =~ s/\\x([0-9a-f]{2})/chr(hex($1))/ge;
365 if($enc = Encode->getEncoding($key)){
366 $tbl{$val} = ref($enc) eq 'Encode::Tcl' ? $enc->loadEncoding : $enc;
372 $obj->{'Seq'} = \@seq; # escape sequences
373 $obj->{'Tbl'} = \%tbl; # encoding tables
379 my ($obj,$str,$chk) = @_;
380 my $tbl = $obj->{'Tbl'};
381 my $seq = $obj->{'Seq'};
385 while (length($str)){
386 my $uch = substr($str,0,1,'');
392 elsif($str =~ s/^\~//)
396 elsif($str =~ s/^([{}])//)
404 carp "unknown HanZi escape sequence: ~$1";
408 if(ref($tbl->{$cur}) eq 'Encode::XS'){
409 $uni .= $tbl->{$cur}->decode($uch);
413 my $rep = $tbl->{$cur}->{'Rep'};
414 my $touni = $tbl->{$cur}->{'ToUni'};
416 if (&$rep($ch) eq 'C')
418 $x = $touni->[0][$ch];
422 $x = $touni->[$ch][ord(substr($str,0,1,''))];
427 # What do we do here ?
432 $_[1] = $str if $chk;
438 my ($obj,$uni,$chk) = @_;
439 my $tbl = $obj->{'Tbl'};
440 my $seq = $obj->{'Seq'};
446 while (length($uni)){
447 my $ch = chr(ord(substr($uni,0,1,'')));
449 foreach my $e_seq (@$seq){
450 $x = ref($tbl->{$e_seq}) eq 'Encode::XS'
451 ? $tbl->{$e_seq}->encode($ch,1)
452 : $tbl->{$e_seq}->{FmUni}->{$ch};
453 $cur = $e_seq and last if defined $x;
455 if(ref($tbl->{$cur}) ne 'Encode::XS')
457 my $def = $tbl->{$cur}->{'Def'};
458 my $rep = $tbl->{$cur}->{'Rep'};
463 $x = pack(&$rep($x),$x);
465 $str .= $cur eq $pre ? $x : ($pre = $cur).$x;
466 $str .= '~' if $x eq '~'; # to '~~'
468 $str .= $std unless $cur eq $std;
469 $_[1] = $uni if $chk;