This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
ext/PerlIO-encoding/t/encoding.t: Skip on EBCDIC
[perl5.git] / ext / PerlIO-encoding / t / encoding.t
CommitLineData
bb7af5ca 1#!./perl -w
9ba8831b
JH
2
3BEGIN {
9ba8831b
JH
4 unless (find PerlIO::Layer 'perlio') {
5 print "1..0 # Skip: not perlio\n";
6 exit 0;
7 }
54cfe943
RB
8 unless (eval { require Encode } ) {
9 print "1..0 # Skip: not Encode\n";
10 exit 0;
11 }
dae3349b
KW
12 if (ord("A") == 193) {
13 print "1..0 # Skip: EBCDIC\n";
14 exit 0;
15 }
aa0bd1ca 16 require "../../t/charset_tools.pl";
9ba8831b
JH
17}
18
8f79eb5b 19use Test::More tests => 24;
08efa405 20
8e86646e
JH
21my $grk = "grk$$";
22my $utf = "utf$$";
92e410c2
MB
23my $fail1 = "fa$$";
24my $fail2 = "fb$$";
ed53a2bb 25my $russki = "koi8r$$";
19d607df 26my $threebyte = "3byte$$";
8e86646e 27
2b18b92a
JH
28if (open(GRK, ">$grk")) {
29 binmode(GRK, ":bytes");
8e86646e
JH
30 # alpha beta gamma in ISO 8859-7
31 print GRK "\xe1\xe2\xe3";
d1e4d418 32 close GRK or die "Could not close: $!";
8e86646e
JH
33}
34
35{
30029c0d
NC
36 is(open(my $i,'<:encoding(iso-8859-7)',$grk), 1);
37 is(open(my $o,'>:utf8',$utf), 1);
38 is((print $o readline $i), 1);
d1e4d418 39 close($o) or die "Could not close: $!";
8e86646e
JH
40 close($i);
41}
42
2b18b92a
JH
43if (open(UTF, "<$utf")) {
44 binmode(UTF, ":bytes");
aa0bd1ca
KW
45
46 # alpha beta gamma in UTF-8 Unicode (0x3b1 0x3b2 0x3b3)
47 is(scalar <UTF>, byte_utf8a_to_utf8n("\xce\xb1\xce\xb2\xce\xb3"));
206b12d5 48 close UTF;
8e86646e
JH
49}
50
51{
52 use Encode;
30029c0d
NC
53 is (open(my $i,'<:utf8',$utf), 1);
54 is (open(my $o,'>:encoding(iso-8859-7)',$grk), 1);
55 is ((scalar print $o readline $i), 1);
d1e4d418 56 close($o) or die "Could not close: $!";
8e86646e
JH
57 close($i);
58}
59
2b18b92a
JH
60if (open(GRK, "<$grk")) {
61 binmode(GRK, ":bytes");
30029c0d 62 is(scalar <GRK>, "\xe1\xe2\xe3");
206b12d5 63 close GRK;
8e86646e
JH
64}
65
bb7af5ca 66$SIG{__WARN__} = sub {$warn .= $_[0]};
b26b1ab5 67
30029c0d
NC
68is (open(FAIL, ">:encoding(NoneSuch)", $fail1), undef, 'Open should fail');
69like($warn, qr/^Cannot find encoding "NoneSuch" at/);
70
71is(open(RUSSKI, ">$russki"), 1);
72print RUSSKI "\x3c\x3f\x78";
73close RUSSKI or die "Could not close: $!";
74open(RUSSKI, "$russki");
75binmode(RUSSKI, ":raw");
76my $buf1;
77read(RUSSKI, $buf1, 1);
78# eof(RUSSKI);
79binmode(RUSSKI, ":encoding(koi8-r)");
80my $buf2;
81read(RUSSKI, $buf2, 1);
82my $offset = tell(RUSSKI);
83is(ord $buf1, 0x3c);
84is(ord $buf2, (ord('A') == 193) ? 0x6f : 0x3f);
85is($offset, 2);
86close RUSSKI;
ed53a2bb 87
bb7af5ca
NC
88undef $warn;
89
90# Check there is no Use of uninitialized value in concatenation (.) warning
91# due to the way @latin2iso_num was used to make aliases.
30029c0d
NC
92is(open(FAIL, ">:encoding(latin42)", $fail2), undef, 'Open should fail');
93
94like($warn, qr/^Cannot find encoding "latin42" at.*line \d+\.$/);
bb7af5ca 95
19d607df
NIS
96# Create a string of chars that are 3 bytes in UTF-8
97my $str = "\x{1f80}" x 2048;
98
99# Write them to a file
100open(F,'>:utf8',$threebyte) || die "Cannot open $threebyte:$!";
101print F $str;
102close(F);
103
104# Read file back as UTF-8
105open(F,'<:encoding(utf-8)',$threebyte) || die "Cannot open $threebyte:$!";
106my $dstr = <F>;
107close(F);
30029c0d 108is($dstr, $str);
19d607df 109
fbadb8fa
GA
110# Try decoding some bad stuff
111open(F,'>:raw',$threebyte) || die "Cannot open $threebyte:$!";
501f55b9
JH
112if (ord('A') == 193) { # EBCDIC
113 print F "foo\x8c\x80\x80\x80bar\n\x80foo\n";
114} else {
115 print F "foo\xF0\x80\x80\x80bar\n\x80foo\n";
116}
fbadb8fa
GA
117close(F);
118
119open(F,'<:encoding(utf-8)',$threebyte) || die "Cannot open $threebyte:$!";
120$dstr = join(":", <F>);
121close(F);
501f55b9 122if (ord('A') == 193) { # EBCDIC
30029c0d 123 is($dstr, "foo\\x8C\\x80\\x80\\x80bar\n:\\x80foo\n");
501f55b9 124} else {
30029c0d 125 is($dstr, "foo\\xF0\\x80\\x80\\x80bar\n:\\x80foo\n");
501f55b9 126}
fbadb8fa 127
667763bd
FC
128# Check that PerlIO::encoding can handle custom encodings that do funny
129# things with the buffer.
130use Encode::Encoding;
131package Extensive {
132 @ISA = Encode::Encoding;
133 __PACKAGE__->Define('extensive');
134 sub encode($$;$) {
135 my ($self,$buf,$chk) = @_;
136 my $leftovers = '';
137 if ($buf =~ /(.*\n)(?!\z)/) {
138 $buf = $1;
139 $leftovers = $';
140 }
141 if ($chk) {
e9a8753a
FC
142 undef $_[1];
143 my @x = (' ') x 8000; # reuse the just-freed buffer
144 $_[1] = $leftovers; # SvPVX now points elsewhere and is shorter
145 } # than bufsiz
667763bd
FC
146 $buf;
147 }
148 no warnings 'once';
149 *decode = *encode;
150}
151open my $fh, ">:encoding(extensive)", \$buf;
152$fh->autoflush;
153print $fh "doughnut\n";
154print $fh "quaffee\n";
e9a8753a
FC
155# Print something longer than the buffer that encode() shrunk:
156print $fh "The beech leaves beech leaves on the beach by the beech.\n";
667763bd 157close $fh;
e9a8753a
FC
158is $buf, "doughnut\nquaffee\nThe beech leaves beech leaves on the beach by"
159 ." the beech.\n", 'buffer realloc during encoding';
667763bd
FC
160$buf = "Sheila surely shod Sean\nin shoddy shoes.\n";
161open $fh, "<:encoding(extensive)", \$buf;
162is join("", <$fh>), "Sheila surely shod Sean\nin shoddy shoes.\n",
163 'buffer realloc during decoding';
164
8f79eb5b
FC
165package Cower {
166 @ISA = Encode::Encoding;
167 __PACKAGE__->Define('cower');
168 sub encode($$;$) {
169 my ($self,$buf,$chk) = @_;
170 my $leftovers = '';
171 if ($buf =~ /(.*\n)(?!\z)/) {
172 $buf = $1;
173 $leftovers = $';
174 }
175 if ($chk) {
176 no warnings; # stupid @_[1] warning
177 @_[1] = keys %{{$leftovers=>1}}; # shared hash key (copy-on-write)
178 }
179 $buf;
180 }
181 no warnings 'once';
182 *decode = *encode;
183}
184open $fh, ">:encoding(cower)", \$buf;
185$fh->autoflush;
186print $fh $_ for qw "pumping plum pits";
187close $fh;
188is $buf, "pumpingplumpits", 'cowing buffer during encoding';
189$buf = "pumping\nplum\npits\n";
190open $fh, "<:encoding(cower)", \$buf;
191is join("", <$fh>), "pumping\nplum\npits\n",
192 'cowing buffer during decoding';
193
667763bd
FC
194package Globber {
195 no warnings 'once';
196 @ISA = Encode::Encoding;
197 __PACKAGE__->Define('globber');
198 sub encode($$;$) {
199 my ($self,$buf,$chk) = @_;
200 $_[1] = *foo if $chk;
201 $buf;
202 }
203 *decode = *encode;
204}
205
206# Here we just want to test there is no crash. The actual output is not so
207# important.
208# We need a double eval, as scope unwinding will close the handle,
209# which croaks.
668a8625
FC
210# Under debugging builds with PERL_DESTRUCT_LEVEL set, we have to skip this
211# test, as it triggers bug #115692, resulting in string table warnings.
212require Config;
213SKIP: {
214skip "produces string table warnings", 2
215 if "@{[Config::non_bincompat_options()]}" =~ /\bDEBUGGING\b/
216 && $ENV{PERL_DESTRUCT_LEVEL};
217
667763bd
FC
218eval { eval {
219 open my $fh, ">:encoding(globber)", \$buf;
220 print $fh "Agathopous Goodfoot\n";
221 close $fh;
222}; $e = $@};
223like $@||$e, qr/Close with partial character/,
224 'no crash when assigning glob to buffer in encode';
225$buf = "To hymn him who heard her herd herd\n";
226open $fh, "<:encoding(globber)", \$buf;
227my $x = <$fh>;
228close $fh;
229is $x, "To hymn him who heard her herd herd\n",
230 'no crash when assigning glob to buffer in decode';
231
668a8625
FC
232} # SKIP
233
8e86646e 234END {
98a392ec 235 1 while unlink($grk, $utf, $fail1, $fail2, $russki, $threebyte);
8e86646e 236}