This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Integrate mainline
[perl5.git] / ext / PerlIO / t / encoding.t
CommitLineData
bb7af5ca 1#!./perl -w
9ba8831b
JH
2
3BEGIN {
4 chdir 't' if -d 't';
5 @INC = '../lib';
bb7af5ca
NC
6 no warnings; # Need global -w flag for later tests, but don't want this
7 # to warn here:
e69a2255 8 push @INC, "::lib:$MacPerl::Architecture:" if $^O eq 'MacOS';
9ba8831b
JH
9 unless (find PerlIO::Layer 'perlio') {
10 print "1..0 # Skip: not perlio\n";
11 exit 0;
12 }
13}
14
bb7af5ca 15print "1..13\n";
08efa405 16
8e86646e
JH
17my $grk = "grk$$";
18my $utf = "utf$$";
92e410c2
MB
19my $fail1 = "fa$$";
20my $fail2 = "fb$$";
ed53a2bb 21my $russki = "koi8r$$";
8e86646e 22
2b18b92a
JH
23if (open(GRK, ">$grk")) {
24 binmode(GRK, ":bytes");
8e86646e
JH
25 # alpha beta gamma in ISO 8859-7
26 print GRK "\xe1\xe2\xe3";
d1e4d418 27 close GRK or die "Could not close: $!";
8e86646e
JH
28}
29
30{
31 use Encode;
32 open(my $i,'<:encoding(iso-8859-7)',$grk);
33 print "ok 1\n";
34 open(my $o,'>:utf8',$utf);
35 print "ok 2\n";
36 print $o readline($i);
37 print "ok 3\n";
d1e4d418 38 close($o) or die "Could not close: $!";
8e86646e
JH
39 close($i);
40}
41
2b18b92a
JH
42if (open(UTF, "<$utf")) {
43 binmode(UTF, ":bytes");
07229bbd
JH
44 if (ord('A') == 193) { # EBCDIC
45 # alpha beta gamma in UTF-EBCDIC Unicode (0x3b1 0x3b2 0x3b3)
46 print "not " unless <UTF> eq "\xb4\x58\xb4\x59\xb4\x62";
47 } else {
48 # alpha beta gamma in UTF-8 Unicode (0x3b1 0x3b2 0x3b3)
49 print "not " unless <UTF> eq "\xce\xb1\xce\xb2\xce\xb3";
50 }
8e86646e 51 print "ok 4\n";
206b12d5 52 close UTF;
8e86646e
JH
53}
54
55{
56 use Encode;
57 open(my $i,'<:utf8',$utf);
58 print "ok 5\n";
59 open(my $o,'>:encoding(iso-8859-7)',$grk);
60 print "ok 6\n";
61 print $o readline($i);
62 print "ok 7\n";
d1e4d418 63 close($o) or die "Could not close: $!";
8e86646e
JH
64 close($i);
65}
66
2b18b92a
JH
67if (open(GRK, "<$grk")) {
68 binmode(GRK, ":bytes");
8e86646e
JH
69 print "not " unless <GRK> eq "\xe1\xe2\xe3";
70 print "ok 8\n";
206b12d5 71 close GRK;
8e86646e
JH
72}
73
bb7af5ca 74$SIG{__WARN__} = sub {$warn .= $_[0]};
b26b1ab5
NC
75
76if (open(FAIL, ">:encoding(NoneSuch)", $fail1)) {
77 print "not ok 9 # Open should fail\n";
78} else {
79 print "ok 9\n";
80}
81if (!defined $warn) {
82 print "not ok 10 # warning is undef\n";
83} elsif ($warn =~ /^Cannot find encoding "NoneSuch" at/) {
84 print "ok 10\n";
85} else {
86 print "not ok 10 # warning is '$warn'";
87}
88
ed53a2bb
JH
89if (open(RUSSKI, ">$russki")) {
90 print RUSSKI "\x3c\x3f\x78";
d1e4d418 91 close RUSSKI or die "Could not close: $!";
ed53a2bb
JH
92 open(RUSSKI, "$russki");
93 binmode(RUSSKI, ":raw");
94 my $buf1;
95 read(RUSSKI, $buf1, 1);
bb7af5ca 96 # eof(RUSSKI);
ed53a2bb
JH
97 binmode(RUSSKI, ":encoding(koi8-r)");
98 my $buf2;
99 read(RUSSKI, $buf2, 1);
100 my $offset = tell(RUSSKI);
07229bbd
JH
101 if (ord($buf1) == 0x3c &&
102 ord($buf2) == (ord('A') == 193) ? 0x6f : 0x3f &&
103 $offset == 2) {
ed53a2bb
JH
104 print "ok 11\n";
105 } else {
07229bbd
JH
106 printf "not ok 11 # [%s] [%s] %d\n",
107 join(" ", unpack("H*", $buf1)),
108 join(" ", unpack("H*", $buf2)), $offset;
ed53a2bb
JH
109 }
110 close(RUSSKI);
111} else {
112 print "not ok 11 # open failed: $!\n";
113}
114
bb7af5ca
NC
115undef $warn;
116
117# Check there is no Use of uninitialized value in concatenation (.) warning
118# due to the way @latin2iso_num was used to make aliases.
119if (open(FAIL, ">:encoding(latin42)", $fail2)) {
120 print "not ok 12 # Open should fail\n";
121} else {
122 print "ok 12\n";
123}
124if (!defined $warn) {
125 print "not ok 13 # warning is undef\n";
126} elsif ($warn =~ /^Cannot find encoding "latin42" at.*line \d+\.$/) {
127 print "ok 13\n";
128} else {
129 print "not ok 13 # warning is: \n";
130 $warn =~ s/^/# /mg;
131 print "$warn";
132}
133
8e86646e 134END {
92e410c2 135 unlink($grk, $utf, $fail1, $fail2, $russki);
8e86646e 136}