1 package Encode::Tcl::Extended;
3 our $VERSION = do {my @r=(q$Revision: 1.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r};
4 use base 'Encode::Encoding';
10 my ($obj,$fh,$name) = @_;
11 my(%tbl, $enc, %ssc, @key);
14 next unless /^(\S+)\s+(.*)$/;
15 my ($key,$val) = ($1,$2);
16 $val =~ s/\{(.*?)\}/$1/;
17 $val =~ s/\\x([0-9a-f]{2})/chr(hex($1))/ge;
19 if($enc = Encode->getEncoding($key))
22 $tbl{$val} = ref($enc) eq 'Encode::Tcl' ? $enc->loadEncoding : $enc;
23 $ssc{$val} = substr($val,1) if $val =~ /^>/;
30 $obj->{'SSC'} = \%ssc; # single shift char
31 $obj->{'Tbl'} = \%tbl; # encoding tables
32 $obj->{'Key'} = \@key; # keys of table hash
38 my ($obj,$str,$chk) = @_;
39 my $name = $obj->{'Name'};
40 my $tbl = $obj->{'Tbl'};
41 my $ssc = $obj->{'SSC'};
42 my $cur = ''; # current state
46 my $cc = substr($str,0,1,'');
48 if(!$cur && $ch > 0x7F)
51 $cur .= $cc, next if $ssc->{$cur.$cc};
55 if(ref($tbl->{$cur}) ne 'Encode::Tcl::Table')
57 $uni .= $tbl->{$cur}->decode($cc);
61 my $rep = $tbl->{$cur}->{'Rep'};
62 my $touni = $tbl->{$cur}->{'ToUni'};
64 if (&$rep($ch) eq 'C')
66 $x = $touni->[0][$ch];
72 $str = $cc; # split leading byte
75 my $c2 = substr($str,0,1,'');
77 $x = $touni->[$ch][0x80 ^ ord($c2)];
81 Encode::Tcl::no_map_in_decode($name, $cc.$str);
89 $_[1] = $cur ne '' ? $cur.$str : $str;
96 my ($obj,$uni,$chk) = @_;
97 my $name = $obj->{'Name'};
98 my $tbl = $obj->{'Tbl'};
99 my $ssc = $obj->{'SSC'};
100 my $key = $obj->{'Key'};
106 my $ch = substr($uni,0,1,'');
108 foreach my $k (@$key)
110 $x = ref($tbl->{$k}) ne 'Encode::Tcl::Table'
112 ? $tbl->{$k}->encode(chr(0x80 ^ ord $ch),1)
113 : $tbl->{$k}->encode($ch,1)
114 : $tbl->{$k}->{FmUni}->{$ch};
115 $cur = $k, last if defined $x;
121 Encode::Tcl::no_map_in_encode(ord($ch), $name)
125 if(ref($tbl->{$cur}) eq 'Encode::Tcl::Table')
127 my $def = $tbl->{$cur}->{'Def'};
128 my $rep = $tbl->{$cur}->{'Rep'};
132 ? $r eq 'C' ? 0x80 ^ $x : 0x8080 ^ $x
135 $str .= $ssc->{$cur} if defined $ssc->{$cur};
138 $_[1] = $uni if $chk;