|
Packit |
d0f5c2 |
BEGIN {
|
|
Packit |
d0f5c2 |
if ($ENV{'PERL_CORE'}){
|
|
Packit |
d0f5c2 |
chdir 't';
|
|
Packit |
d0f5c2 |
unshift @INC, '../lib';
|
|
Packit |
d0f5c2 |
}
|
|
Packit |
d0f5c2 |
if (ord("A") == 193) {
|
|
Packit |
d0f5c2 |
print "1..0 # Skip: EBCDIC\n";
|
|
Packit |
d0f5c2 |
exit 0;
|
|
Packit |
d0f5c2 |
}
|
|
Packit |
d0f5c2 |
require Config; import Config;
|
|
Packit |
d0f5c2 |
if ($Config{'extensions'} !~ /\bEncode\b/) {
|
|
Packit |
d0f5c2 |
print "1..0 # Skip: Encode was not built\n";
|
|
Packit |
d0f5c2 |
exit 0;
|
|
Packit |
d0f5c2 |
}
|
|
Packit |
d0f5c2 |
}
|
|
Packit |
d0f5c2 |
use strict;
|
|
Packit |
d0f5c2 |
use Test::More;
|
|
Packit |
d0f5c2 |
use Encode qw(from_to encode decode
|
|
Packit |
d0f5c2 |
encode_utf8 decode_utf8
|
|
Packit |
d0f5c2 |
find_encoding is_utf8);
|
|
Packit |
d0f5c2 |
use charnames qw(greek);
|
|
Packit |
d0f5c2 |
my @encodings = grep(/iso-?8859/,Encode::encodings());
|
|
Packit |
d0f5c2 |
my $n = 2;
|
|
Packit |
d0f5c2 |
my @character_set = ('0'..'9', 'A'..'Z', 'a'..'z');
|
|
Packit |
d0f5c2 |
my @source = qw(ascii iso8859-1 cp1250);
|
|
Packit |
d0f5c2 |
my @destiny = qw(cp1047 cp37 posix-bc);
|
|
Packit |
d0f5c2 |
my @ebcdic_sets = qw(cp1047 cp37 posix-bc);
|
|
Packit |
d0f5c2 |
plan tests => 38+$n*@encodings + 2*@source*@destiny*@character_set + 2*@ebcdic_sets*256 + 6 + 3 + 3*8 + 2;
|
|
Packit |
d0f5c2 |
|
|
Packit |
d0f5c2 |
my $str = join('',map(chr($_),0x20..0x7E));
|
|
Packit |
d0f5c2 |
my $cpy = $str;
|
|
Packit |
d0f5c2 |
is length($str),from_to($cpy,'iso8859-1','Unicode'),"Length Wrong";
|
|
Packit |
d0f5c2 |
is $cpy,$str,"ASCII mangled by translating from iso8859-1 to Unicode";
|
|
Packit |
d0f5c2 |
$cpy = $str;
|
|
Packit |
d0f5c2 |
is from_to($cpy,'Unicode','iso8859-1'),length($str),"Length wrong";
|
|
Packit |
d0f5c2 |
is $cpy,$str,"ASCII mangled by translating from Unicode to iso8859-1";
|
|
Packit |
d0f5c2 |
|
|
Packit |
d0f5c2 |
$str = join('',map(chr($_),0xa0..0xff));
|
|
Packit |
d0f5c2 |
$cpy = $str;
|
|
Packit |
d0f5c2 |
is length($str),from_to($cpy,'iso8859-1','Unicode'),"Length Wrong";
|
|
Packit |
d0f5c2 |
|
|
Packit |
d0f5c2 |
my $sym = Encode->getEncoding('symbol');
|
|
Packit |
d0f5c2 |
my $uni = $sym->decode(encode(ascii => 'a'));
|
|
Packit |
d0f5c2 |
is "\N{alpha}",substr($uni,0,1),"alpha does not map to symbol 'a'";
|
|
Packit |
d0f5c2 |
$str = $sym->encode("\N{Beta}");
|
|
Packit |
d0f5c2 |
is "B",decode(ascii => substr($str,0,1)),"Symbol 'B' does not map to Beta";
|
|
Packit |
d0f5c2 |
|
|
Packit |
d0f5c2 |
foreach my $enc (qw(symbol dingbats ascii),@encodings)
|
|
Packit |
d0f5c2 |
{
|
|
Packit |
d0f5c2 |
my $tab = Encode->getEncoding($enc);
|
|
Packit |
d0f5c2 |
is 1,defined($tab),"Could not load $enc";
|
|
Packit |
d0f5c2 |
$str = join('',map(chr($_),0x20..0x7E));
|
|
Packit |
d0f5c2 |
$uni = $tab->decode($str);
|
|
Packit |
d0f5c2 |
$cpy = $tab->encode($uni);
|
|
Packit |
d0f5c2 |
is $cpy,$str,"$enc mangled translating to Unicode and back";
|
|
Packit |
d0f5c2 |
}
|
|
Packit |
d0f5c2 |
|
|
Packit |
d0f5c2 |
# On ASCII based machines see if we can map several codepoints from
|
|
Packit |
d0f5c2 |
# three distinct ASCII sets to three distinct EBCDIC coded character sets.
|
|
Packit |
d0f5c2 |
# On EBCDIC machines see if we can map from three EBCDIC sets to three
|
|
Packit |
d0f5c2 |
# distinct ASCII sets.
|
|
Packit |
d0f5c2 |
|
|
Packit |
d0f5c2 |
my @expectation = (240..249, 193..201,209..217,226..233, 129..137,145..153,162..169);
|
|
Packit |
d0f5c2 |
if (ord('A') != 65) {
|
|
Packit |
d0f5c2 |
my @temp = @destiny;
|
|
Packit |
d0f5c2 |
@destiny = @source;
|
|
Packit |
d0f5c2 |
@source = @temp;
|
|
Packit |
d0f5c2 |
undef(@temp);
|
|
Packit |
d0f5c2 |
@expectation = (48..57, 65..90, 97..122);
|
|
Packit |
d0f5c2 |
}
|
|
Packit |
d0f5c2 |
|
|
Packit |
d0f5c2 |
foreach my $to (@destiny)
|
|
Packit |
d0f5c2 |
{
|
|
Packit |
d0f5c2 |
foreach my $from (@source)
|
|
Packit |
d0f5c2 |
{
|
|
Packit |
d0f5c2 |
my @expected = @expectation;
|
|
Packit |
d0f5c2 |
foreach my $chr (@character_set)
|
|
Packit |
d0f5c2 |
{
|
|
Packit |
d0f5c2 |
my $native_chr = $chr;
|
|
Packit |
d0f5c2 |
my $cpy = $chr;
|
|
Packit |
d0f5c2 |
my $rc = from_to($cpy,$from,$to);
|
|
Packit |
d0f5c2 |
is 1,$rc,"Could not translate from $from to $to";
|
|
Packit |
d0f5c2 |
is ord($cpy),shift(@expected),"mangled translating $native_chr from $from to $to";
|
|
Packit |
d0f5c2 |
}
|
|
Packit |
d0f5c2 |
}
|
|
Packit |
d0f5c2 |
}
|
|
Packit |
d0f5c2 |
|
|
Packit |
d0f5c2 |
# On either ASCII or EBCDIC machines ensure we can take the full one
|
|
Packit |
d0f5c2 |
# byte repetoire to EBCDIC sets and back.
|
|
Packit |
d0f5c2 |
|
|
Packit |
d0f5c2 |
my $enc_as = 'iso8859-1';
|
|
Packit |
d0f5c2 |
foreach my $enc_eb (@ebcdic_sets)
|
|
Packit |
d0f5c2 |
{
|
|
Packit |
d0f5c2 |
foreach my $ord (0..255)
|
|
Packit |
d0f5c2 |
{
|
|
Packit |
d0f5c2 |
$str = chr($ord);
|
|
Packit |
d0f5c2 |
my $rc = from_to($str,$enc_as,$enc_eb);
|
|
Packit |
d0f5c2 |
$rc += from_to($str,$enc_eb,$enc_as);
|
|
Packit |
d0f5c2 |
is $rc,2,"return code for $ord $enc_eb -> $enc_as -> $enc_eb was not obtained";
|
|
Packit |
d0f5c2 |
is $ord,ord($str),"$enc_as mangled translating $ord to $enc_eb and back";
|
|
Packit |
d0f5c2 |
}
|
|
Packit |
d0f5c2 |
}
|
|
Packit |
d0f5c2 |
|
|
Packit |
d0f5c2 |
my $mime = find_encoding('iso-8859-2');
|
|
Packit |
d0f5c2 |
is defined($mime),1,"Cannot find MIME-ish'iso-8859-2'";
|
|
Packit |
d0f5c2 |
my $x11 = find_encoding('iso8859-2');
|
|
Packit |
d0f5c2 |
is defined($x11),1,"Cannot find X11-ish 'iso8859-2'";
|
|
Packit |
d0f5c2 |
is $mime,$x11,"iso8598-2 and iso-8859-2 not same";
|
|
Packit |
d0f5c2 |
my $spc = find_encoding('iso 8859-2');
|
|
Packit |
d0f5c2 |
is defined($spc),1,"Cannot find 'iso 8859-2'";
|
|
Packit |
d0f5c2 |
is $spc,$mime,"iso 8859-2 and iso-8859-2 not same";
|
|
Packit |
d0f5c2 |
|
|
Packit |
d0f5c2 |
for my $i (256,128,129,256)
|
|
Packit |
d0f5c2 |
{
|
|
Packit |
d0f5c2 |
my $c = chr($i);
|
|
Packit |
d0f5c2 |
my $s = "$c\n".sprintf("%02X",$i);
|
|
Packit |
d0f5c2 |
is utf8::valid($s),1,"concat of $i botched";
|
|
Packit |
d0f5c2 |
utf8::upgrade($s);
|
|
Packit |
d0f5c2 |
is utf8::valid($s),1,"concat of $i botched";
|
|
Packit |
d0f5c2 |
}
|
|
Packit |
d0f5c2 |
|
|
Packit |
d0f5c2 |
# Spot check a few points in/out of utf8
|
|
Packit |
d0f5c2 |
for my $i (ord('A'),128,256,0x20AC)
|
|
Packit |
d0f5c2 |
{
|
|
Packit |
d0f5c2 |
my $c = chr($i);
|
|
Packit |
d0f5c2 |
my $o = encode_utf8($c);
|
|
Packit |
d0f5c2 |
is decode_utf8($o),$c,"decode_utf8 not inverse of encode_utf8 for $i";
|
|
Packit |
d0f5c2 |
is encode('utf8',$c),$o,"utf8 encode by name broken for $i";
|
|
Packit |
d0f5c2 |
is decode('utf8',$o),$c,"utf8 decode by name broken for $i";
|
|
Packit |
d0f5c2 |
}
|
|
Packit |
d0f5c2 |
|
|
Packit |
d0f5c2 |
|
|
Packit |
d0f5c2 |
# is_utf8
|
|
Packit |
d0f5c2 |
|
|
Packit |
d0f5c2 |
ok( is_utf8("\x{100}"));
|
|
Packit |
d0f5c2 |
ok(! is_utf8("a"));
|
|
Packit |
d0f5c2 |
ok(! is_utf8(""));
|
|
Packit |
d0f5c2 |
"\x{100}" =~ /(.)/;
|
|
Packit |
d0f5c2 |
ok( is_utf8($1)); # ID 20011127.151
|
|
Packit |
d0f5c2 |
$a = $1;
|
|
Packit |
d0f5c2 |
ok( is_utf8($a));
|
|
Packit |
d0f5c2 |
$a = "\x{100}";
|
|
Packit |
d0f5c2 |
chop $a;
|
|
Packit |
d0f5c2 |
ok( is_utf8($a)); # weird but true: an empty UTF-8 string
|
|
Packit |
d0f5c2 |
|
|
Packit |
d0f5c2 |
# non-string arguments
|
|
Packit |
d0f5c2 |
package Encode::Dummy;
|
|
Packit |
d0f5c2 |
use overload q("") => sub { $_[0]->[0] };
|
|
Packit |
d0f5c2 |
sub new { my $class = shift; bless [ @_ ] => $class }
|
|
Packit |
d0f5c2 |
package main;
|
|
Packit |
d0f5c2 |
ok(decode(latin1 => Encode::Dummy->new("foobar")), "foobar");
|
|
Packit |
d0f5c2 |
ok(encode(utf8 => Encode::Dummy->new("foobar")), "foobar");
|
|
Packit |
d0f5c2 |
|
|
Packit |
d0f5c2 |
# RT#91569
|
|
Packit |
d0f5c2 |
# decode_utf8 with non-string arguments
|
|
Packit |
d0f5c2 |
ok(decode_utf8(*1), "*main::1");
|
|
Packit |
d0f5c2 |
|
|
Packit |
d0f5c2 |
# hash keys
|
|
Packit |
d0f5c2 |
foreach my $name ("UTF-16LE", "UTF-8", "Latin1") {
|
|
Packit |
d0f5c2 |
my $key = (keys %{{ "whatever\x{CA}" => '' }})[0];
|
|
Packit |
d0f5c2 |
my $kopy = $key;
|
|
Packit |
d0f5c2 |
encode($name, $kopy, Encode::FB_CROAK);
|
|
Packit |
d0f5c2 |
is $key, "whatever\x{CA}", "encode $name with shared hash key scalars";
|
|
Packit |
d0f5c2 |
undef $key;
|
|
Packit |
d0f5c2 |
$key = (keys %{{ "whatever\x{CA}" => '' }})[0];
|
|
Packit |
d0f5c2 |
$kopy = $key;
|
|
Packit |
d0f5c2 |
encode($name, $kopy, Encode::FB_CROAK | Encode::LEAVE_SRC);
|
|
Packit |
d0f5c2 |
is $key, "whatever\x{CA}", "encode $name with LEAVE_SRC and shared hash key scalars";
|
|
Packit |
d0f5c2 |
undef $key;
|
|
Packit |
d0f5c2 |
$key = (keys %{{ "whatever" => '' }})[0];
|
|
Packit |
d0f5c2 |
$kopy = $key;
|
|
Packit |
d0f5c2 |
decode($name, $kopy, Encode::FB_CROAK);
|
|
Packit |
d0f5c2 |
is $key, "whatever", "decode $name with shared hash key scalars";
|
|
Packit |
d0f5c2 |
undef $key;
|
|
Packit |
d0f5c2 |
$key = (keys %{{ "whatever" => '' }})[0];
|
|
Packit |
d0f5c2 |
$kopy = $key;
|
|
Packit |
d0f5c2 |
decode($name, $kopy, Encode::FB_CROAK | Encode::LEAVE_SRC);
|
|
Packit |
d0f5c2 |
is $key, "whatever", "decode $name with LEAVE_SRC and shared hash key scalars";
|
|
Packit |
d0f5c2 |
|
|
Packit |
d0f5c2 |
my $enc = find_encoding($name);
|
|
Packit |
d0f5c2 |
undef $key;
|
|
Packit |
d0f5c2 |
$key = (keys %{{ "whatever\x{CA}" => '' }})[0];
|
|
Packit |
d0f5c2 |
$kopy = $key;
|
|
Packit |
d0f5c2 |
$enc->encode($kopy, Encode::FB_CROAK);
|
|
Packit |
d0f5c2 |
is $key, "whatever\x{CA}", "encode obj $name with shared hash key scalars";
|
|
Packit |
d0f5c2 |
undef $key;
|
|
Packit |
d0f5c2 |
$key = (keys %{{ "whatever\x{CA}" => '' }})[0];
|
|
Packit |
d0f5c2 |
$kopy = $key;
|
|
Packit |
d0f5c2 |
$enc->encode($kopy, Encode::FB_CROAK | Encode::LEAVE_SRC);
|
|
Packit |
d0f5c2 |
is $key, "whatever\x{CA}", "encode obj $name with LEAVE_SRC and shared hash key scalars";
|
|
Packit |
d0f5c2 |
undef $key;
|
|
Packit |
d0f5c2 |
$key = (keys %{{ "whatever" => '' }})[0];
|
|
Packit |
d0f5c2 |
$kopy = $key;
|
|
Packit |
d0f5c2 |
$enc->decode($kopy, Encode::FB_CROAK);
|
|
Packit |
d0f5c2 |
is $key, "whatever", "decode obj $name with shared hash key scalars";
|
|
Packit |
d0f5c2 |
undef $key;
|
|
Packit |
d0f5c2 |
$key = (keys %{{ "whatever" => '' }})[0];
|
|
Packit |
d0f5c2 |
$kopy = $key;
|
|
Packit |
d0f5c2 |
$enc->decode($kopy, Encode::FB_CROAK | Encode::LEAVE_SRC);
|
|
Packit |
d0f5c2 |
is $key, "whatever", "decode obj $name with LEAVE_SRC and shared hash key scalars";
|
|
Packit |
d0f5c2 |
}
|
|
Packit |
d0f5c2 |
|
|
Packit |
d0f5c2 |
my $latin1 = find_encoding('latin1');
|
|
Packit |
d0f5c2 |
my $orig = "\316";
|
|
Packit |
d0f5c2 |
$orig =~ /(.)/;
|
|
Packit |
d0f5c2 |
is $latin1->encode($1), $orig, '[cpan #115168] passing magic regex globals to encode';
|
|
Packit |
d0f5c2 |
SKIP: {
|
|
Packit |
d0f5c2 |
skip "Perl Version ($]) is older than v5.16", 1 if $] < 5.016;
|
|
Packit |
d0f5c2 |
*a = $orig;
|
|
Packit |
d0f5c2 |
is $latin1->encode(*a), '*main::'.$orig, '[cpan #115168] passing typeglobs to encode';
|
|
Packit |
d0f5c2 |
}
|