BEGIN {
require
Config; Config->
import
();
if
(
$Config
{
'extensions'
} !~ /\bEncode\b/) {
print
"1..0 # Skip: Encode was not built\n"
;
exit
0;
}
unless
(find PerlIO::Layer
'perlio'
) {
print
"1..0 # Skip: PerlIO was not built\n"
;
exit
0;
}
if
(
ord
(
"A"
) == 193) {
print
"1..0 # Skip: encoding pragma does not support EBCDIC platforms\n"
;
exit
(0);
}
if
($] >= 5.025 and !
$Config
{usecperl}) {
print
"1..0 # Skip: encoding pragma not supported in Perl 5.25 or later\n"
;
exit
(0);
}
}
print
"1..33\n"
;
no
warnings
"deprecated"
;
$a
=
"\xDF"
;
$b
=
"\x{100}"
;
print
"not "
unless
ord
(
$a
) == 0x3af;
print
"ok 1\n"
;
print
"not "
unless
ord
(
$b
) == 0x100;
print
"ok 2\n"
;
my
$c
;
$c
=
$a
.
$b
;
print
"not "
unless
ord
(
$c
) == 0x3af;
print
"ok 3\n"
;
print
"not "
unless
length
(
$c
) == 2;
print
"ok 4\n"
;
print
"not "
unless
ord
(
substr
(
$c
, 1, 1)) == 0x100;
print
"ok 5\n"
;
print
"not "
unless
ord
(
chr
(0xdf)) == 0x3af;
print
"ok 6\n"
;
print
"not "
unless
ord
(
pack
(
"C"
, 0xdf)) == 0x3af;
print
"ok 7\n"
;
print
"not "
unless
unpack
(
"C"
,
pack
(
"C"
, 0xdf)) == 0xdf;
print
"ok 8\n"
;
print
"not "
unless
unpack
(
"U0 C"
,
chr
(0xdf)) == 0xce;
print
"ok 9\n"
;
print
"not "
unless
unpack
(
"U"
,
pack
(
"U"
, 0xdf)) == 0xdf;
print
"ok 10\n"
;
print
"not "
unless
unpack
(
"U"
,
chr
(0xdf)) == 0x3af;
print
"ok 11\n"
;
print
"not "
unless
ord
(
"\N{LATIN SMALL LETTER SHARP S}"
) == 0xdf;
print
"ok 12\n"
;
$c
=
"\xDF\N{LATIN SMALL LETTER SHARP S}"
.
chr
(0xdf);
print
"not "
unless
ord
(
$c
) == 0x3af;
print
"ok 13\n"
;
print
"not "
unless
ord
(
substr
(
$c
, 1, 1)) == 0xdf;
print
"ok 14\n"
;
print
"not "
unless
ord
(
substr
(
$c
, 2, 1)) == 0x3af;
print
"ok 15\n"
;
print
"not "
unless
"\xDF"
=~ /\x{3AF}/;
print
"ok 16\n"
;
print
"not "
unless
"\x{3AF}"
=~ /\xDF/;
print
"ok 17\n"
;
print
"not "
unless
"\xDF"
=~ /\xDF/;
print
"ok 18\n"
;
print
"not "
unless
"\x{3AF}"
=~ /\x{3AF}/;
print
"ok 19\n"
;
my
(
$byte
,
$bytes
,
$U
,
$Ub
,
$g1
,
$g2
,
$l
) = (
pack
(
"C*"
, 0xDF ),
pack
(
"C*"
, 0xDF, 0x20),
pack
(
"U*"
, 0x3AF),
pack
(
"U*"
, 0xDF ),
pack
(
"U*"
, 0x3B1),
pack
(
"U*"
, 0x3AF, 0x20),
pack
(
"U*"
, 0x3AB),
);
sub
alleq($$){
my
(
$a
,
$b
) = (
shift
,
shift
);
$a
eq
$b
&&
$b
eq
$a
&&
!(
$a
ne
$b
) && !(
$b
ne
$a
) &&
(
$a
cmp
$b
) == 0 && (
$b
cmp
$a
) == 0;
}
sub
anyeq($$){
my
(
$a
,
$b
) = (
shift
,
shift
);
$a
eq
$b
||
$b
eq
$a
||
!(
$a
ne
$b
) || !(
$b
ne
$a
) ||
(
$a
cmp
$b
) == 0 || (
$b
cmp
$a
) == 0;
}
sub
allgt($$){
my
(
$a
,
$b
) = (
shift
,
shift
);
(
$a
cmp
$b
) == 1 && (
$b
cmp
$a
) == -1;
}
print
"not "
unless
alleq(
$byte
,
$U
);
print
"ok 20\n"
;
print
"not "
if
anyeq(
$byte
,
$Ub
);
print
"ok 21\n"
;
print
"not "
unless
allgt (
$g1
,
$byte
) &&
allgt (
$g2
,
$byte
) &&
allgt (
$byte
,
$l
) &&
allgt (
$bytes
,
$U
);
print
"ok 22\n"
;
my
(
$u
,
$v
,
$v2
);
$u
=
$v
=
$v2
=
pack
(
"C*"
, 0xDF);
utf8::upgrade(
$v
);
$v2
=
substr
(
$v2
.
"\x{410}"
, 0, -1);
print
"not "
if
do
{{
use
bytes;
$v
ne
$v2
}} ||
$v
ne
$v2
;
print
"ok 23\n"
;
print
"not "
unless
alleq(
$u
,
$v
);
print
"ok 24\n"
;
$u
=
$v
=
pack
(
"C*"
, 0xDF);
utf8::upgrade(
$v
);
eval
{utf8::downgrade(
$v
)};
print
"not "
if
$@ !~ /^Wide / ||
do
{{
use
bytes;
$u
eq
$v
}} ||
$u
ne
$v
;
print
"ok 25\n"
;
$byte
=
pack
(
"C*"
, 0xDF);
print
"not "
unless
pack
(
"U*"
, 0x3AF) eq
$byte
;
print
"ok 26\n"
;
print
"not "
if
chr
(0xDF) cmp
$byte
;
print
"ok 27\n"
;
print
"not "
unless
((
pack
(
"U*"
, 0x3B0) cmp
$byte
) == 1) &&
((
pack
(
"U*"
, 0x3AE) cmp
$byte
) == -1) &&
((
pack
(
"U*"
, 0x3AF, 0x20) cmp
$byte
) == 1) &&
((
pack
(
"U*"
, 0x3AF) cmp
pack
(
"C*"
,0xDF,0x20))==-1);
print
"ok 28\n"
;
{
no
warnings;
print
ord
(
undef
) == 0 ?
"ok 29\n"
:
"not ok 29\n"
;
}
{
my
%h1
;
my
%h2
;
$h1
{
"\xdf"
} = 41;
$h2
{
"\x{3af}"
} = 42;
print
$h1
{
"\x{3af}"
} == 41 ?
"ok 30\n"
:
"not ok 30\n"
;
print
$h2
{
"\xdf"
} == 42 ?
"ok 31\n"
:
"not ok 31\n"
;
}
{
print
"not "
if
"\xDF\x{100}"
=~ /\x{3af}\x{100}/;
print
"ok 32\n"
;
print
"not "
if
"\x{100}\xDF"
=~ /\x{100}\x{3af}/;
print
"ok 33\n"
;
}