ext/Encode/Encode/7bit-greek.enc Encode table
ext/Encode/Encode/7bit-jis.enc Encode table
ext/Encode/Encode/7bit-kana.enc Encode table
-ext/Encode/Encode/7bit-kr.enc Encode table
ext/Encode/Encode/7bit-latin1.enc Encode table
ext/Encode/Encode/8859-1.enc Encode table
ext/Encode/Encode/8859-1.ucm Encode table
ext/Encode/lib/Encode/Tcl.pm Encode extension
ext/Encode/lib/Encode/Tcl/Escape.pm Encode extension
ext/Encode/lib/Encode/Tcl/Extended.pm Encode extension
-ext/Encode/lib/Encode/Tcl/HanZi.pm Encode extension
ext/Encode/lib/Encode/Tcl/Table.pm Encode extension
ext/Encode/lib/Encode/ucs2_le.pm Encode extension
ext/Encode/lib/Encode/Unicode.pm Encode extension
+++ /dev/null
-package Encode::Tcl::HanZi;
-our $VERSION = do {my @r=(q$Revision: 1.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r};
-use base 'Encode::Encoding';
-
-use Carp;
-
-sub read
-{
- my ($obj,$fh,$name) = @_;
- my(%tbl, @seq, $enc);
- while (<$fh>)
- {
- next unless /^(\S+)\s+(.*)$/;
- my ($key,$val) = ($1,$2);
- $val =~ s/^\{(.*?)\}/$1/g;
- $val =~ s/\\x([0-9a-f]{2})/chr(hex($1))/ge;
- if($enc = Encode->getEncoding($key))
- {
- $tbl{$val} = ref($enc) eq 'Encode::Tcl' ? $enc->loadEncoding : $enc;
- push @seq, $val;
- }
- else
- {
- $obj->{$key} = $val;
- }
- }
- $obj->{'Seq'} = \@seq; # escape sequences
- $obj->{'Tbl'} = \%tbl; # encoding tables
- return $obj;
-}
-
-sub decode
-{
- my ($obj,$str,$chk) = @_;
- my $name = $obj->{'Name'};
- my $tbl = $obj->{'Tbl'};
- my $seq = $obj->{'Seq'};
- my $std = $seq->[0];
- my $cur = $std;
- my $uni;
- while (length($str)){
- my $cc = substr($str,0,1,'');
- if($cc eq "~")
- {
- if($str =~ s/^\cJ//)
- {
- next;
- }
- elsif($str =~ s/^\~//)
- {
- 1; # no-op
- }
- elsif($str =~ s/^([{}])//)
- {
- $cur = "~$1";
- next;
- }
- elsif(! length $str)
- {
- $str = '~';
- last;
- }
- else
- {
- $str =~ s/^([^~])//;
- croak "unknown HanZi escape sequence: ~$1";
- next;
- }
- }
- if(ref($tbl->{$cur}) ne 'Encode::Tcl::Table')
- {
- $uni .= $tbl->{$cur}->decode($cc);
- next;
- }
- my $ch = ord($cc);
- my $rep = $tbl->{$cur}->{'Rep'};
- my $touni = $tbl->{$cur}->{'ToUni'};
- my $x;
- if (&$rep($ch) eq 'C')
- {
- $x = $touni->[0][$ch];
- }
- else
- {
- if(! length $str)
- {
- $str = $cc; # split leading byte
- last;
- }
- my $c2 = substr($str,0,1,'');
- $cc .= $c2;
- $x = $touni->[$ch][ord($c2)];
- }
- unless (defined $x)
- {
- Encode::Tcl::no_map_in_decode($name, $cc.$str);
- }
- $uni .= $x;
- }
- if($chk)
- {
- $_[1] = $cur eq $std ? $str : $cur.$str;
- }
- return $uni;
-}
-
-sub encode
-{
- my ($obj,$uni,$chk) = @_;
- my $name = $obj->{'Name'};
- my $tbl = $obj->{'Tbl'};
- my $seq = $obj->{'Seq'};
- my $std = $seq->[0];
- my $str;
- my $pre = $std;
- my $cur = $pre;
-
- while (length($uni))
- {
- my $ch = substr($uni,0,1,'');
- my $x;
- foreach my $e_seq (@$seq)
- {
- $x = ref($tbl->{$e_seq}) eq 'Encode::Tcl::Table'
- ? $tbl->{$e_seq}->{FmUni}->{$ch}
- : $tbl->{$e_seq}->encode($ch,1);
- $cur = $e_seq and last if defined $x;
- }
- unless (defined $x)
- {
- unless($chk)
- {
- Encode::Tcl::no_map_in_encode(ord($ch), $name)
- }
- return undef;
- }
- if(ref($tbl->{$cur}) eq 'Encode::Tcl::Table')
- {
- my $def = $tbl->{$cur}->{'Def'};
- my $rep = $tbl->{$cur}->{'Rep'};
- $x = pack(&$rep($x),$x);
- }
- $str .= $cur eq $pre ? $x : ($pre = $cur).$x;
- $str .= '~' if $x eq '~'; # to '~~'
- }
- $str .= $std unless $cur eq $std;
- $_[1] = $uni if $chk;
- return $str;
-}
-1;
-__END__