INC_search();
}
+sub no_map_in_encode ($$)
+ # codepoint, enc-name;
+{
+ carp sprintf "\"\\N{U+%x}\" does not map to %s", @_;
+# /* FIXME: Skip over the character, copy in replacement and continue
+# * but that is messy so for now just fail.
+# */
+ return;
+}
+
+sub no_map_in_decode ($$)
+ # enc-name, string beginning the malform char;
+{
+# /* UTF-8 is supposed to be "Universal" so should not happen */
+ croak sprintf "%s '%s' does not map to UTF-8", @_;
+}
+
sub encode
{
my $obj = shift;
$type = substr($line,0,1);
last unless $type eq '#';
}
- my $class = ref($obj).('::'.(
- ($type eq 'X') ? 'Extended' :
- ($type eq 'H') ? 'HanZi' :
- ($type eq 'E') ? 'Escape' : 'Table'
- ));
+ my $subclass =
+ ($type eq 'X') ? 'Extended' :
+ ($type eq 'H') ? 'HanZi' :
+ ($type eq 'E') ? 'Escape' : 'Table';
+ my $class = ref($obj) . '::' . $subclass;
# carp "Loading $file";
bless $obj,$class;
return $obj if $obj->read($fh,$obj->name,$type);
package Encode::Tcl::Table;
use base 'Encode::Encoding';
-use Data::Dumper;
+use Carp;
+#use Data::Dumper;
sub read
{
}
$touni[$page] = \@page;
}
- $rep = $type ne 'M' ? $obj->can("rep_$type") :
- sub { ($_[0] > 255) || $leading[$_[0]] ? 'n' : 'C'};
+ $rep = $type ne 'M'
+ ? $obj->can("rep_$type")
+ : sub
+ {
+ ($_[0] > 255) || $leading[$_[0]] ? 'n' : 'C';
+ };
$obj->{'Rep'} = $rep;
$obj->{'ToUni'} = \@touni;
$obj->{'FmUni'} = \%fmuni;
sub decode
{
- my ($obj,$str,$chk) = @_;
+ my($obj,$str,$chk) = @_;
+ my $name = $obj->{'Name'};
my $rep = $obj->{'Rep'};
my $touni = $obj->{'ToUni'};
my $uni;
while (length($str))
{
- my $ch = ord(substr($str,0,1,''));
+ my $cc = substr($str,0,1,'');
+ my $ch = ord($cc);
my $x;
if (&$rep($ch) eq 'C')
{
}
else
{
- $x = $touni->[$ch][ord(substr($str,0,1,''))];
+ if(! length $str)
+ {
+ $str = pack('C',$ch); # split leading byte
+ last;
+ }
+ my $c2 = substr($str,0,1,'');
+ $cc .= $c2;
+ $x = $touni->[$ch][ord($c2)];
}
unless (defined $x)
{
- last if $chk;
- # What do we do here ?
- $x = '';
+ Encode::Tcl::no_map_in_decode($name, $cc.$str);
}
$uni .= $x;
}
my ($obj,$uni,$chk) = @_;
my $fmuni = $obj->{'FmUni'};
my $def = $obj->{'Def'};
+ my $name = $obj->{'Name'};
my $rep = $obj->{'Rep'};
my $str;
while (length($uni))
{
my $ch = substr($uni,0,1,'');
- my $x = $fmuni->{chr(ord($ch))};
- unless (defined $x)
+ my $x = $fmuni->{$ch};
+ unless(defined $x)
{
- last if ($chk);
- $x = $def;
+ unless($chk)
+ {
+ Encode::Tcl::no_map_in_encode(ord($ch), $name)
+ }
+ return undef;
}
$str .= pack(&$rep($x),$x);
}
use Carp;
+use constant SI => "\cO";
+use constant SO => "\cN";
+use constant SS2 => "\eN";
+use constant SS3 => "\eO";
+
sub read
{
my ($obj,$fh,$name) = @_;
my(%tbl, @seq, $enc, @esc, %grp);
while (<$fh>)
{
- my ($key,$val) = /^(\S+)\s+(.*)$/;
+ 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)){
+ if($enc = Encode->getEncoding($key))
+ {
$tbl{$val} = ref($enc) eq 'Encode::Tcl' ? $enc->loadEncoding : $enc;
push @seq, $val;
$grp{$val} =
- $val =~ m|[(]| ? 0 : # G0 : SI eq "\cO"
- $val =~ m|[)-]| ? 1 : # G1 : SO eq "\cN"
- $val =~ m|[*.]| ? 2 : # G2 : SS2 eq "\eN"
- $val =~ m|[+/]| ? 3 : # G3 : SS3 eq "\eO"
- 0; # G0
- }else{
+ $val =~ m|[(]| ? 0 : # G0 : SI eq "\cO"
+ $val =~ m|[)-]| ? 1 : # G1 : SO eq "\cN"
+ $val =~ m|[*.]| ? 2 : # G2 : SS2 eq "\eN"
+ $val =~ m|[+/]| ? 3 : # G3 : SS3 eq "\eO"
+ 0; # G0
+ }
+ else
+ {
$obj->{$key} = $val;
- }
- if($val =~ /^\e(.*)/){ push(@esc, quotemeta $1) }
+ }
+ if($val =~ /^\e(.*)/)
+ {
+ push(@esc, quotemeta $1);
+ }
}
$obj->{'Grp'} = \%grp; # graphic chars
$obj->{'Seq'} = \@seq; # escape sequences
sub decode
{
my ($obj,$str,$chk) = @_;
+ my $name = $obj->{'Name'};
my $tbl = $obj->{'Tbl'};
my $seq = $obj->{'Seq'};
my $grp = $obj->{'Grp'};
my $s = 0; # state of SO-SI. 0 (G0) or 1 (G1);
my $ss = 0; # state of SS2,SS3. 0 (G0), 2 (G2) or 3 (G3);
my $uni;
- while (length($str)){
- my $uch = substr($str,0,1,'');
- if($uch eq "\e"){
- if($str =~ s/^($esc)//)
- {
- my $e = "\e$1";
- $sta[ $grp->{$e} ] = $e if $tbl->{$e};
- }
+ while (length($str))
+ {
+ my $cc = substr($str,0,1,'');
+ if($cc eq "\e")
+ {
+ if($str =~ s/^($esc)//)
+ {
+ my $e = "\e$1";
+ $sta[ $grp->{$e} ] = $e if $tbl->{$e};
+ }
# appearance of "\eN\eO" or "\eO\eN" isn't supposed.
- elsif($str =~ s/^N//)
- {
- $ss = 2;
- }
- elsif($str =~ s/^O//)
- {
- $ss = 3;
- }
- else
- {
- $str =~ s/^([\x20-\x2F]*[\x30-\x7E])//;
- carp "unknown escape sequence: ESC $1";
- }
- next;
- }
- if($uch eq "\x0e"){
- $s = 1; next;
- }
- if($uch eq "\x0f"){
- $s = 0; next;
- }
+ # but in that case, the former will be ignored.
+ elsif($str =~ s/^N//)
+ {
+ $ss = 2;
+ }
+ elsif($str =~ s/^O//)
+ {
+ $ss = 3;
+ }
+ else
+ {
+ # strictly, ([\x20-\x2F]*[\x30-\x7E]). '?' for chopped.
+ $str =~ s/^([\x20-\x2F]*[\x30-\x7E]?)//;
+ if($chk && ! length $str)
+ {
+ $str = "\e$1"; # split sequence
+ last;
+ }
+ croak "unknown escape sequence: ESC $1";
+ }
+ next;
+ }
+ if($cc eq SO)
+ {
+ $s = 1; next;
+ }
+ if($cc eq SI)
+ {
+ $s = 0; next;
+ }
$cur = $ss ? $sta[$ss] : $sta[$s];
- if(ref($tbl->{$cur}) eq 'Encode::XS'){
- $uni .= $tbl->{$cur}->decode($uch);
+ if(ref($tbl->{$cur}) ne 'Encode::Tcl::Table')
+ {
+ $uni .= $tbl->{$cur}->decode($cc);
$ss = 0;
next;
- }
- my $ch = ord($uch);
+ }
+ my $ch = ord($cc);
my $rep = $tbl->{$cur}->{'Rep'};
my $touni = $tbl->{$cur}->{'ToUni'};
my $x;
}
else
{
- $x = $touni->[$ch][ord(substr($str,0,1,''))];
+ 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)
{
- last if $chk;
- # What do we do here ?
- $x = '';
+ Encode::Tcl::no_map_in_decode($name, $cc.$str);
}
$uni .= $x;
$ss = 0;
}
- $_[1] = $str if $chk;
- return $uni;
+ if($chk)
+ {
+ my $back = join('', grep defined($_) && $_ ne $std, @sta);
+ $back .= SO if $s;
+ $back .= $ss == 2 ? SS2 : SS3 if $ss;
+ $_[1] = $back.$str;
+ }
+ return $uni;
}
sub encode
{
my ($obj,$uni,$chk) = @_;
+ my $name = $obj->{'Name'};
my $tbl = $obj->{'Tbl'};
my $seq = $obj->{'Seq'};
my $grp = $obj->{'Grp'};
if($ini && defined $grp->{$ini})
{
- $sta[ $grp->{$ini} ] = $ini;
+ $sta[ $grp->{$ini} ] = $ini;
}
- while (length($uni)){
- my $ch = 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, last if defined $x;
- }
- 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;
+ 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, last if defined $x;
}
- $x = pack(&$rep($x),$x);
+ unless (defined $x)
+ {
+ unless($chk)
+ {
+ Encode::Tcl::no_map_in_encode(ord($ch), $name)
+ }
+ return undef;
}
- $cG = $grp->{$cur};
- $str .= $sta[$cG] = $cur unless $cG < 2 && $cur eq $sta[$cG];
-
- $str .= $cG == 0 && $pG == 1 ? "\cO" :
- $cG == 1 && $pG == 0 ? "\cN" :
- $cG == 2 ? "\eN" :
- $cG == 3 ? "\eO" : "";
- $str .= $x;
- $pG = $cG if $cG < 2;
- }
- $str .= "\cO" if $pG == 1; # back to G0
+ if(ref($tbl->{$cur}) eq 'Encode::Tcl::Table')
+ {
+ my $def = $tbl->{$cur}->{'Def'};
+ my $rep = $tbl->{$cur}->{'Rep'};
+ $x = pack(&$rep($x),$x);
+ }
+ $cG = $grp->{$cur};
+ $str .= $sta[$cG] = $cur unless $cG < 2 && $cur eq $sta[$cG];
+
+ $str .= $cG == 0 && $pG == 1 ? SI :
+ $cG == 1 && $pG == 0 ? SO :
+ $cG == 2 ? SS2 :
+ $cG == 3 ? SS3 : "";
+ $str .= $x;
+ $pG = $cG if $cG < 2;
+ }
+ $str .= SI if $pG == 1; # back to G0
$str .= $std unless $std eq $sta[0]; # GO to ASCII
$str .= $fin; # necessary?
$_[1] = $uni if $chk;
my(%tbl, $enc, %ssc, @key);
while (<$fh>)
{
- my ($key,$val) = /^(\S+)\s+(.*)$/;
+ next unless /^(\S+)\s+(.*)$/;
+ my ($key,$val) = ($1,$2);
$val =~ s/\{(.*?)\}/$1/;
$val =~ s/\\x([0-9a-f]{2})/chr(hex($1))/ge;
- if($enc = Encode->getEncoding($key)){
+ if($enc = Encode->getEncoding($key))
+ {
push @key, $val;
- $tbl{$val} = ref($enc) eq 'Encode::Tcl'
- ? $enc->loadEncoding : $enc;
+ $tbl{$val} = ref($enc) eq 'Encode::Tcl' ? $enc->loadEncoding : $enc;
$ssc{$val} = substr($val,1) if $val =~ /^>/;
- }else{
+ }
+ else
+ {
$obj->{$key} = $val;
- }
+ }
}
$obj->{'SSC'} = \%ssc; # single shift char
$obj->{'Tbl'} = \%tbl; # encoding tables
sub decode
{
my ($obj,$str,$chk) = @_;
- my $tbl = $obj->{'Tbl'};
- my $ssc = $obj->{'SSC'};
+ my $name = $obj->{'Name'};
+ my $tbl = $obj->{'Tbl'};
+ my $ssc = $obj->{'SSC'};
my $cur = ''; # current state
my $uni;
- while (length($str)){
- my $uch = substr($str,0,1,'');
- my $ch = ord($uch);
+ while (length($str))
+ {
+ my $cc = substr($str,0,1,'');
+ my $ch = ord($cc);
if(!$cur && $ch > 0x7F)
{
$cur = '>';
- $cur .= $uch, next if $ssc->{$cur.$uch};
+ $cur .= $cc, next if $ssc->{$cur.$cc};
}
$ch ^= 0x80 if $cur;
- if(ref($tbl->{$cur}) eq 'Encode::XS'){
- $uni .= $tbl->{$cur}->decode(chr($ch));
+ if(ref($tbl->{$cur}) ne 'Encode::Tcl::Table')
+ {
+ $uni .= $tbl->{$cur}->decode($cc);
$cur = '';
next;
- }
+ }
my $rep = $tbl->{$cur}->{'Rep'};
my $touni = $tbl->{$cur}->{'ToUni'};
my $x;
}
else
{
- $x = $touni->[$ch][0x80 ^ ord(substr($str,0,1,''))];
+ if(! length $str)
+ {
+ $str = $cc; # split leading byte
+ last;
+ }
+ my $c2 = substr($str,0,1,'');
+ $cc .= $c2;
+ $x = $touni->[$ch][0x80 ^ ord($c2)];
}
unless (defined $x)
{
- last if $chk;
- # What do we do here ?
- $x = '';
+ Encode::Tcl::no_map_in_decode($name, $cc.$str);
}
$uni .= $x;
$cur = '';
}
- $_[1] = $str if $chk;
+ if($chk)
+ {
+ $cur =~ s/>//;
+ $_[1] = $cur ne '' ? $cur.$str : $str;
+ }
return $uni;
}
sub encode
{
my ($obj,$uni,$chk) = @_;
+ my $name = $obj->{'Name'};
my $tbl = $obj->{'Tbl'};
my $ssc = $obj->{'SSC'};
my $key = $obj->{'Key'};
my $str;
my $cur;
- while (length($uni)){
- my $ch = substr($uni,0,1,'');
- my $x;
- foreach my $k (@$key){
- $x = ref($tbl->{$k}) eq 'Encode::XS'
- ? $k =~ /^>/
- ? $tbl->{$k}->encode(chr(0x80 ^ ord $ch),1)
- : $tbl->{$k}->encode($ch,1)
- : $tbl->{$k}->{FmUni}->{$ch};
- $cur = $k, last if defined $x;
- }
- 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;
- }
- my $r = &$rep($x);
- $x = pack($r,
+ while (length($uni))
+ {
+ my $ch = substr($uni,0,1,'');
+ my $x;
+ foreach my $k (@$key)
+ {
+ $x = ref($tbl->{$k}) ne 'Encode::Tcl::Table'
+ ? $k =~ /^>/
+ ? $tbl->{$k}->encode(chr(0x80 ^ ord $ch),1)
+ : $tbl->{$k}->encode($ch,1)
+ : $tbl->{$k}->{FmUni}->{$ch};
+ $cur = $k, 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'};
+ my $r = &$rep($x);
+ $x = pack($r,
$cur =~ /^>/
? $r eq 'C' ? 0x80 ^ $x : 0x8080 ^ $x
: $x);
- }
-
- $str .= $ssc->{$cur} if defined $ssc->{$cur};
- $str .= $x;
- }
+ }
+ $str .= $ssc->{$cur} if defined $ssc->{$cur};
+ $str .= $x;
+ }
$_[1] = $uni if $chk;
return $str;
}
my(%tbl, @seq, $enc);
while (<$fh>)
{
- my ($key,$val) = /^(\S+)\s+(.*)$/;
+ 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)){
+ if($enc = Encode->getEncoding($key))
+ {
$tbl{$val} = ref($enc) eq 'Encode::Tcl' ? $enc->loadEncoding : $enc;
push @seq, $val;
- }else{
+ }
+ else
+ {
$obj->{$key} = $val;
- }
+ }
}
$obj->{'Seq'} = \@seq; # escape sequences
$obj->{'Tbl'} = \%tbl; # encoding tables
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 $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'){
- $uni .= $tbl->{$cur}->decode($uch);
+ 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($uch);
+ }
+ my $ch = ord($cc);
my $rep = $tbl->{$cur}->{'Rep'};
my $touni = $tbl->{$cur}->{'ToUni'};
my $x;
}
else
{
- $x = $touni->[$ch][ord(substr($str,0,1,''))];
+ 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)
{
- last if $chk;
- # What do we do here ?
- $x = '';
+ Encode::Tcl::no_map_in_decode($name, $cc.$str);
}
$uni .= $x;
}
- $_[1] = $str if $chk;
+ 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 $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;
- }
- 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;
+ 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;
}
- $x = pack(&$rep($x),$x);
- }
- $str .= $cur eq $pre ? $x : ($pre = $cur).$x;
- $str .= '~' if $x eq '~'; # to '~~'
- }
+ 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;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
+# @INC = '../lib';
require Config; import Config;
if ($Config{'extensions'} !~ /\bEncode\b/) {
print "1..0 # Skip: Encode was not built\n";
my $hz_exp = '007e0069006e002000470042002e5df162404e0d6b32'
. 'ff0c52ff65bd65bc4eba3002004200790065002e007e';
+use constant BUFSIZ => 64; # for test
+use constant hiragana => "\x{3042}\x{3044}\x{3046}\x{3048}\x{304A}";
+use constant han_kana => "\x{FF71}\x{FF72}\x{FF73}\x{FF74}\x{FF75}";
+use constant macron => "\x{0100}\x{0112}\x{012a}\x{014c}\x{016a}";
+use constant TAIL => 'bbb';
+use constant YES => 1;
+
+my @ary_buff = ( # [ encoding, decoded, encoded ]
+# type-M
+ ["euc-cn", hiragana, "\xA4\xA2\xA4\xA4\xA4\xA6\xA4\xA8\xA4\xAA" ],
+ ["euc-jp", hiragana, "\xA4\xA2\xA4\xA4\xA4\xA6\xA4\xA8\xA4\xAA" ],
+ ["euc-jp", han_kana, "\x8E\xB1\x8E\xB2\x8E\xB3\x8E\xB4\x8E\xB5" ],
+ ["euc-kr", hiragana, "\xAA\xA2\xAA\xA4\xAA\xA6\xAA\xA8\xAA\xAA" ],
+ ["shiftjis", hiragana, "\x82\xA0\x82\xA2\x82\xA4\x82\xA6\x82\xA8" ],
+ ["shiftjis", han_kana, "\xB1\xB2\xB3\xB4\xB5" ],
+# type-E
+ ["2022-cn", hiragana, "\e\$)A\cN". '$"$$$&$($*' . "\cO" ],
+ ["2022-jp", hiragana, "\e\$B".'$"$$$&$($*'."\e(B" ],
+ ["2022-kr", hiragana, "\e\$)C\cN". '*"*$*&*(**' . "\cO" ],
+ [ $jis, han_kana, "\e\(I".'12345'."\e(B" ],
+ ["2022-jp1", macron, "\e\$(D\x2A\x27\x2A\x37\x2A\x45\x2A\x57\x2A\x69\e(B"],
+ ["2022-jp2", "\x{C0}" . macron . "\x{C1}",
+ "\e\$(D\e.A\eN\x40\x2A\x27\x2A\x37\x2A\x45\x2A\x57\x2A\x69\e(B\eN\x41"],
+# type-X
+ ["euc-jp-0212", hiragana, "\xA4\xA2\xA4\xA4\xA4\xA6\xA4\xA8\xA4\xAA" ],
+ ["euc-jp-0212", han_kana, "\x8E\xB1\x8E\xB2\x8E\xB3\x8E\xB4\x8E\xB5" ],
+ ["euc-jp-0212", macron,
+ "\x8F\xAA\xA7\x8F\xAA\xB7\x8F\xAA\xC5\x8F\xAA\xD7\x8F\xAA\xE9" ],
+# type-H
+ [ $hz, hiragana, "~{". '$"$$$&$($*' . "~}" ],
+ [ $hz, hiragana, "~{". '$"$$' ."~\cJ". '$&$($*' . "~}" ],
+);
+
plan test => $n*@encodings + $n*@encodings*@greek
- + $n*@encodings*@ideodigit + $num_esc + $n + @hz_txt;
+ + $n*@encodings*@ideodigit + $num_esc + $n + @hz_txt + @ary_buff;
foreach my $enc (@encodings)
{
}
}
}
+
+for my $ary (@ary_buff) {
+ my $NG = 0;
+ my $enc = $ary->[0];
+ for my $n ( int(BUFSIZ/2) .. 2*BUFSIZ+4 ){
+ my $dst = "a"x$n. $ary->[1] . TAIL;
+ my $src = "a"x$n. $ary->[2] . TAIL;
+ my $utf = buff_decode($enc, $src);
+ $NG++ unless $dst eq $utf;
+ }
+ ok($NG, 0, "$enc mangled translating to Unicode");
+}
+
+sub buff_decode {
+ my($enc, $str) = @_;
+ my $utf8 = '';
+ my $inconv = '';
+ while(length $str){
+ my $buff = $inconv.substr($str,0,BUFSIZ - length $inconv,'');
+ my $decoded = decode($enc, $buff, YES);
+ if(length $decoded){
+ $utf8 .= $decoded;
+ $inconv = $buff;
+ } else {
+ last; # malformed?
+ }
+ }
+ return $utf8;
+}
+
projects / p5sagit/p5-mst-13.2.git / commitdiff