$type = substr($line,0,1);
last unless $type eq '#';
}
- my $class = ref($obj).('::'.(($type eq 'E') ? 'Escape' : 'Table'));
+ my $class = ref($obj).('::'.(($type eq 'H') ? 'HanZi' : ($type eq 'E') ? 'Escape' : 'Table'));
# carp "Loading $file";
bless $obj,$class;
return $obj if $obj->read($fh,$obj->name,$type);
while (length($uni)){
my $ch = chr(ord(substr($uni,0,1,'')));
- my $x = ref($tbl->{$pre}) eq 'Encode::XS'
- ? $tbl->{$pre}->encode($ch,1)
- : $tbl->{$pre}->{FmUni}->{$ch};
-
- unless(defined $x){
- foreach my $e_seq (@$seq){
- $x = ref($tbl->{$e_seq}) eq 'Encode::XS'
- ? $tbl->{$e_seq}->encode($ch,1)
- : $tbl->{$e_seq}->{FmUni}->{$ch};
- $cur = $e_seq and last if defined $x;
- }
+ my $x;
+ foreach my $e_seq ($std, $pre, @$seq){
+ $x = ref($tbl->{$e_seq}) eq 'Encode::XS'
+ ? $tbl->{$e_seq}->encode($ch,1)
+ : $tbl->{$e_seq}->{FmUni}->{$ch};
+ $cur = $e_seq and last if defined $x;
}
- if($x == 0x0d && !($ini eq '' && $fin eq '') && substr($uni,0,1) eq "\x0a")
+ if(ref($tbl->{$cur}) ne 'Encode::XS')
{
- $str .= $cur unless $cur eq $pre;
- $str .= $fin."\x0d\x0a".$ini;
- substr($uni,0,1,'');
- $pre = $std;
- next;
+ my $def = $tbl->{$cur}->{'Def'};
+ my $rep = $tbl->{$cur}->{'Rep'};
+ unless (defined $x){
+ last if ($chk);
+ $x = $def;
+ }
+ $x = pack(&$rep($x),$x);
+ }
+ $str .= $cur eq $pre ? $x : ($pre = $cur).$x;
+ }
+ $str .= $std unless $cur eq $std;
+ $str .= $fin;
+ $_[1] = $uni if $chk;
+ return $str;
+}
+
+package Encode::Tcl::HanZi;
+use base 'Encode::Encoding';
+
+use Carp;
+
+sub read
+{
+ my ($obj,$fh,$name) = @_;
+ my(%tbl, @seq, $enc);
+ while (<$fh>)
+ {
+ my ($key,$val) = /^(\S+)\s+(.*)$/;
+ $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 $tbl = $obj->{'Tbl'};
+ my $seq = $obj->{'Seq'};
+ my $std = $seq->[0];
+ my $cur = $std;
+ my $uni;
+ while (length($str)){
+ my $uch = substr($str,0,1,'');
+ if($uch eq "~"){
+ if($str =~ s/^\cJ//)
+ {
+ next;
+ }
+ elsif($str =~ s/^\~//)
+ {
+ 1;
+ }
+ elsif($str =~ s/^([{}])//)
+ {
+ $cur = "~$1";
+ next;
+ }
+ else
+ {
+ $str =~ s/^([^~])//;
+ carp "unknown HanZi escape sequence: ~$1";
+ next;
+ }
}
- if(ref($tbl->{$cur}) eq 'Encode::XS'){
- $str .= $cur unless $cur eq $pre;
- $str .= $x; # "DEF" is lost
- $pre = $cur;
- next;
+ if(ref($tbl->{$cur}) eq 'Encode::XS'){
+ $uni .= $tbl->{$cur}->decode($uch);
+ next;
+ }
+ my $ch = ord($uch);
+ my $rep = $tbl->{$cur}->{'Rep'};
+ my $touni = $tbl->{$cur}->{'ToUni'};
+ my $x;
+ if (&$rep($ch) eq 'C')
+ {
+ $x = $touni->[0][$ch];
+ }
+ else
+ {
+ $x = $touni->[$ch][ord(substr($str,0,1,''))];
+ }
+ unless (defined $x)
+ {
+ last if $chk;
+ # What do we do here ?
+ $x = '';
+ }
+ $uni .= $x;
}
- my $def = $tbl->{$cur}->{'Def'};
- my $rep = $tbl->{$cur}->{'Rep'};
- unless (defined $x){
- last if ($chk);
- $x = $def;
+ $_[1] = $str if $chk;
+ return $uni;
+}
+
+sub encode
+{
+ my ($obj,$uni,$chk) = @_;
+ 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 = chr(ord(substr($uni,0,1,'')));
+ my $x;
+ foreach my $e_seq (@$seq){
+ $x = ref($tbl->{$e_seq}) eq 'Encode::XS'
+ ? $tbl->{$e_seq}->encode($ch,1)
+ : $tbl->{$e_seq}->{FmUni}->{$ch};
+ $cur = $e_seq and last if defined $x;
}
- $str .= $cur unless $cur eq $pre;
- $str .= pack(&$rep($x),$x);
- $pre = $cur;
+ if(ref($tbl->{$cur}) ne 'Encode::XS')
+ {
+ my $def = $tbl->{$cur}->{'Def'};
+ my $rep = $tbl->{$cur}->{'Rep'};
+ unless (defined $x){
+ last if ($chk);
+ $x = $def;
+ }
+ $x = pack(&$rep($x),$x);
+ }
+ $str .= $cur eq $pre ? $x : ($pre = $cur).$x;
+ $str .= '~' if $x eq '~'; # to '~~'
}
$str .= $std unless $cur eq $std;
- $str .= $fin;
$_[1] = $uni if $chk;
return $str;
}
+
1;
__END__
my @ideodigit = qw(one two three four five six seven eight nine ten);
my $jis = '7bit-jis';
-my $kr = '7bit-kr';
+my $kr = 'iso2022-kr';
my %esc_str;
$esc_str{$jis} = {qw(
my $num_esc = $n * keys(%esc_str);
foreach (values %esc_str){ $num_esc += $n * keys %$_ }
+my $hz = 'HZ'; # HanZi
+
+my @hz_txt = (
+ "~~in GB.~{<:Ky2;S{#,NpJ)l6HK!#~}Bye.~~",
+ "~~in GB.~{<:Ky2;S{#,~}~\cJ~{NpJ)l6HK!#~}Bye.~~",
+ "~~in GB.~\cJ~{<:Ky2;S{#,NpJ)l6HK!#~}~\cJBye.~~",
+);
+
+my $hz_exp = '007e0069006e002000470042002e5df162404e0d6b32'
+ . 'ff0c52ff65bd65bc4eba3002004200790065002e007e';
+
plan test => $n*@encodings + $n*@encodings*@greek
- + $n*@encodings*@ideodigit + $num_esc;
+ + $n*@encodings*@ideodigit + $num_esc + $n + @hz_txt;
foreach my $enc (@encodings)
{
"$enc mangled translating to Unicode");
}
}
+
+
+{
+ my $hz_to_unicode = sub
+ {
+ return unpack('H*', pack 'n*', unpack 'U*', decode $hz, shift);
+ };
+
+ my $hz_from_unicode = sub
+ {
+ return encode($hz, pack 'U*', unpack 'n*', pack 'H*', shift);
+ };
+
+ foreach my $enc ($hz)
+ {
+ my $tab = Encode->getEncoding($enc);
+ ok(1,defined($tab),"Could not load $enc");
+
+ ok(&$hz_from_unicode($hz_exp), $hz_txt[0],
+ "$enc mangled translating from Unicode");
+
+ foreach my $str (@hz_txt)
+ {
+ ok(&$hz_to_unicode($str), $hz_exp,
+ "$enc mangled translating to Unicode");
+ }
+ }
+}
projects / p5sagit/p5-mst-13.2.git / commitdiff