1 package Encode::Tcl::HanZi;
2 our $VERSION = do {my @r=(q$Revision: 1.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r};
3 use base 'Encode::Encoding';
9 my ($obj,$fh,$name) = @_;
13 next unless /^(\S+)\s+(.*)$/;
14 my ($key,$val) = ($1,$2);
15 $val =~ s/^\{(.*?)\}/$1/g;
16 $val =~ s/\\x([0-9a-f]{2})/chr(hex($1))/ge;
17 if($enc = Encode->getEncoding($key))
19 $tbl{$val} = ref($enc) eq 'Encode::Tcl' ? $enc->loadEncoding : $enc;
27 $obj->{'Seq'} = \@seq; # escape sequences
28 $obj->{'Tbl'} = \%tbl; # encoding tables
34 my ($obj,$str,$chk) = @_;
35 my $name = $obj->{'Name'};
36 my $tbl = $obj->{'Tbl'};
37 my $seq = $obj->{'Seq'};
42 my $cc = substr($str,0,1,'');
49 elsif($str =~ s/^\~//)
53 elsif($str =~ s/^([{}])//)
66 croak "unknown HanZi escape sequence: ~$1";
70 if(ref($tbl->{$cur}) ne 'Encode::Tcl::Table')
72 $uni .= $tbl->{$cur}->decode($cc);
76 my $rep = $tbl->{$cur}->{'Rep'};
77 my $touni = $tbl->{$cur}->{'ToUni'};
79 if (&$rep($ch) eq 'C')
81 $x = $touni->[0][$ch];
87 $str = $cc; # split leading byte
90 my $c2 = substr($str,0,1,'');
92 $x = $touni->[$ch][ord($c2)];
96 Encode::Tcl::no_map_in_decode($name, $cc.$str);
102 $_[1] = $cur eq $std ? $str : $cur.$str;
109 my ($obj,$uni,$chk) = @_;
110 my $name = $obj->{'Name'};
111 my $tbl = $obj->{'Tbl'};
112 my $seq = $obj->{'Seq'};
120 my $ch = substr($uni,0,1,'');
122 foreach my $e_seq (@$seq)
124 $x = ref($tbl->{$e_seq}) eq 'Encode::Tcl::Table'
125 ? $tbl->{$e_seq}->{FmUni}->{$ch}
126 : $tbl->{$e_seq}->encode($ch,1);
127 $cur = $e_seq and last if defined $x;
133 Encode::Tcl::no_map_in_encode(ord($ch), $name)
137 if(ref($tbl->{$cur}) eq 'Encode::Tcl::Table')
139 my $def = $tbl->{$cur}->{'Def'};
140 my $rep = $tbl->{$cur}->{'Rep'};
141 $x = pack(&$rep($x),$x);
143 $str .= $cur eq $pre ? $x : ($pre = $cur).$x;
144 $str .= '~' if $x eq '~'; # to '~~'
146 $str .= $std unless $cur eq $std;
147 $_[1] = $uni if $chk;