This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Prune some dead code in pp.c:pp_undef
[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 }
9ba8831b
JH
12}
13
667763bd 14use Test::More tests => 22;
08efa405 15
8e86646e
JH
16my $grk = "grk$$";
17my $utf = "utf$$";
92e410c2
MB
18my $fail1 = "fa$$";
19my $fail2 = "fb$$";
ed53a2bb 20my $russki = "koi8r$$";
19d607df 21my $threebyte = "3byte$$";
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{
30029c0d
NC
31 is(open(my $i,'<:encoding(iso-8859-7)',$grk), 1);
32 is(open(my $o,'>:utf8',$utf), 1);
33 is((print $o readline $i), 1);
d1e4d418 34 close($o) or die "Could not close: $!";
8e86646e
JH
35 close($i);
36}
37
2b18b92a
JH
38if (open(UTF, "<$utf")) {
39 binmode(UTF, ":bytes");
07229bbd
JH
40 if (ord('A') == 193) { # EBCDIC
41 # alpha beta gamma in UTF-EBCDIC Unicode (0x3b1 0x3b2 0x3b3)
30029c0d 42 is(scalar <UTF>, "\xb4\x58\xb4\x59\xb4\x62");
07229bbd
JH
43 } else {
44 # alpha beta gamma in UTF-8 Unicode (0x3b1 0x3b2 0x3b3)
30029c0d 45 is(scalar <UTF>, "\xce\xb1\xce\xb2\xce\xb3");
07229bbd 46 }
206b12d5 47 close UTF;
8e86646e
JH
48}
49
50{
51 use Encode;
30029c0d
NC
52 is (open(my $i,'<:utf8',$utf), 1);
53 is (open(my $o,'>:encoding(iso-8859-7)',$grk), 1);
54 is ((scalar print $o readline $i), 1);
d1e4d418 55 close($o) or die "Could not close: $!";
8e86646e
JH
56 close($i);
57}
58
2b18b92a
JH
59if (open(GRK, "<$grk")) {
60 binmode(GRK, ":bytes");
30029c0d 61 is(scalar <GRK>, "\xe1\xe2\xe3");
206b12d5 62 close GRK;
8e86646e
JH
63}
64
bb7af5ca 65$SIG{__WARN__} = sub {$warn .= $_[0]};
b26b1ab5 66
30029c0d
NC
67is (open(FAIL, ">:encoding(NoneSuch)", $fail1), undef, 'Open should fail');
68like($warn, qr/^Cannot find encoding "NoneSuch" at/);
69
70is(open(RUSSKI, ">$russki"), 1);
71print RUSSKI "\x3c\x3f\x78";
72close RUSSKI or die "Could not close: $!";
73open(RUSSKI, "$russki");
74binmode(RUSSKI, ":raw");
75my $buf1;
76read(RUSSKI, $buf1, 1);
77# eof(RUSSKI);
78binmode(RUSSKI, ":encoding(koi8-r)");
79my $buf2;
80read(RUSSKI, $buf2, 1);
81my $offset = tell(RUSSKI);
82is(ord $buf1, 0x3c);
83is(ord $buf2, (ord('A') == 193) ? 0x6f : 0x3f);
84is($offset, 2);
85close RUSSKI;
ed53a2bb 86
bb7af5ca
NC
87undef $warn;
88
89# Check there is no Use of uninitialized value in concatenation (.) warning
90# due to the way @latin2iso_num was used to make aliases.
30029c0d
NC
91is(open(FAIL, ">:encoding(latin42)", $fail2), undef, 'Open should fail');
92
93like($warn, qr/^Cannot find encoding "latin42" at.*line \d+\.$/);
bb7af5ca 94
19d607df
NIS
95# Create a string of chars that are 3 bytes in UTF-8
96my $str = "\x{1f80}" x 2048;
97
98# Write them to a file
99open(F,'>:utf8',$threebyte) || die "Cannot open $threebyte:$!";
100print F $str;
101close(F);
102
103# Read file back as UTF-8
104open(F,'<:encoding(utf-8)',$threebyte) || die "Cannot open $threebyte:$!";
105my $dstr = <F>;
106close(F);
30029c0d 107is($dstr, $str);
19d607df 108
fbadb8fa
GA
109# Try decoding some bad stuff
110open(F,'>:raw',$threebyte) || die "Cannot open $threebyte:$!";
501f55b9
JH
111if (ord('A') == 193) { # EBCDIC
112 print F "foo\x8c\x80\x80\x80bar\n\x80foo\n";
113} else {
114 print F "foo\xF0\x80\x80\x80bar\n\x80foo\n";
115}
fbadb8fa
GA
116close(F);
117
118open(F,'<:encoding(utf-8)',$threebyte) || die "Cannot open $threebyte:$!";
119$dstr = join(":", <F>);
120close(F);
501f55b9 121if (ord('A') == 193) { # EBCDIC
30029c0d 122 is($dstr, "foo\\x8C\\x80\\x80\\x80bar\n:\\x80foo\n");
501f55b9 123} else {
30029c0d 124 is($dstr, "foo\\xF0\\x80\\x80\\x80bar\n:\\x80foo\n");
501f55b9 125}
fbadb8fa 126
667763bd
FC
127# Check that PerlIO::encoding can handle custom encodings that do funny
128# things with the buffer.
129use Encode::Encoding;
130package Extensive {
131 @ISA = Encode::Encoding;
132 __PACKAGE__->Define('extensive');
133 sub encode($$;$) {
134 my ($self,$buf,$chk) = @_;
135 my $leftovers = '';
136 if ($buf =~ /(.*\n)(?!\z)/) {
137 $buf = $1;
138 $leftovers = $';
139 }
140 if ($chk) {
e9a8753a
FC
141 undef $_[1];
142 my @x = (' ') x 8000; # reuse the just-freed buffer
143 $_[1] = $leftovers; # SvPVX now points elsewhere and is shorter
144 } # than bufsiz
667763bd
FC
145 $buf;
146 }
147 no warnings 'once';
148 *decode = *encode;
149}
150open my $fh, ">:encoding(extensive)", \$buf;
151$fh->autoflush;
152print $fh "doughnut\n";
153print $fh "quaffee\n";
e9a8753a
FC
154# Print something longer than the buffer that encode() shrunk:
155print $fh "The beech leaves beech leaves on the beach by the beech.\n";
667763bd 156close $fh;
e9a8753a
FC
157is $buf, "doughnut\nquaffee\nThe beech leaves beech leaves on the beach by"
158 ." the beech.\n", 'buffer realloc during encoding';
667763bd
FC
159$buf = "Sheila surely shod Sean\nin shoddy shoes.\n";
160open $fh, "<:encoding(extensive)", \$buf;
161is join("", <$fh>), "Sheila surely shod Sean\nin shoddy shoes.\n",
162 'buffer realloc during decoding';
163
164package Globber {
165 no warnings 'once';
166 @ISA = Encode::Encoding;
167 __PACKAGE__->Define('globber');
168 sub encode($$;$) {
169 my ($self,$buf,$chk) = @_;
170 $_[1] = *foo if $chk;
171 $buf;
172 }
173 *decode = *encode;
174}
175
176# Here we just want to test there is no crash. The actual output is not so
177# important.
178# We need a double eval, as scope unwinding will close the handle,
179# which croaks.
180eval { eval {
181 open my $fh, ">:encoding(globber)", \$buf;
182 print $fh "Agathopous Goodfoot\n";
183 close $fh;
184}; $e = $@};
185like $@||$e, qr/Close with partial character/,
186 'no crash when assigning glob to buffer in encode';
187$buf = "To hymn him who heard her herd herd\n";
188open $fh, "<:encoding(globber)", \$buf;
189my $x = <$fh>;
190close $fh;
191is $x, "To hymn him who heard her herd herd\n",
192 'no crash when assigning glob to buffer in decode';
193
8e86646e 194END {
98a392ec 195 1 while unlink($grk, $utf, $fail1, $fail2, $russki, $threebyte);
8e86646e 196}