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
1 #!./perl -w
2
3 BEGIN {
4     unless (find PerlIO::Layer 'perlio') {
5         print "1..0 # Skip: not perlio\n";
6         exit 0;
7     }
8     unless (eval { require Encode } ) {
9         print "1..0 # Skip: not Encode\n";
10         exit 0;
11     }
12     if (ord("A") == 193) {
13         print "1..0 # Skip: EBCDIC\n";
14         exit 0;
15     }
16     require "../../t/charset_tools.pl";
17 }
18
19 use Test::More tests => 24;
20
21 my $grk = "grk$$";
22 my $utf = "utf$$";
23 my $fail1 = "fa$$";
24 my $fail2 = "fb$$";
25 my $russki = "koi8r$$";
26 my $threebyte = "3byte$$";
27
28 if (open(GRK, ">$grk")) {
29     binmode(GRK, ":bytes");
30     # alpha beta gamma in ISO 8859-7
31     print GRK "\xe1\xe2\xe3";
32     close GRK or die "Could not close: $!";
33 }
34
35 {
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);
39     close($o) or die "Could not close: $!";
40     close($i);
41 }
42
43 if (open(UTF, "<$utf")) {
44     binmode(UTF, ":bytes");
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"));
48     close UTF;
49 }
50
51 {
52     use Encode;
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);
56     close($o) or die "Could not close: $!";
57     close($i);
58 }
59
60 if (open(GRK, "<$grk")) {
61     binmode(GRK, ":bytes");
62     is(scalar <GRK>, "\xe1\xe2\xe3");
63     close GRK;
64 }
65
66 $SIG{__WARN__} = sub {$warn .= $_[0]};
67
68 is (open(FAIL, ">:encoding(NoneSuch)", $fail1), undef, 'Open should fail');
69 like($warn, qr/^Cannot find encoding "NoneSuch" at/);
70
71 is(open(RUSSKI, ">$russki"), 1);
72 print RUSSKI "\x3c\x3f\x78";
73 close RUSSKI or die "Could not close: $!";
74 open(RUSSKI, "$russki");
75 binmode(RUSSKI, ":raw");
76 my $buf1;
77 read(RUSSKI, $buf1, 1);
78 # eof(RUSSKI);
79 binmode(RUSSKI, ":encoding(koi8-r)");
80 my $buf2;
81 read(RUSSKI, $buf2, 1);
82 my $offset = tell(RUSSKI);
83 is(ord $buf1, 0x3c);
84 is(ord $buf2, (ord('A') == 193) ? 0x6f : 0x3f);
85 is($offset, 2);
86 close RUSSKI;
87
88 undef $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.
92 is(open(FAIL, ">:encoding(latin42)", $fail2), undef, 'Open should fail');
93
94 like($warn, qr/^Cannot find encoding "latin42" at.*line \d+\.$/);
95
96 # Create a string of chars that are 3 bytes in UTF-8 
97 my $str = "\x{1f80}" x 2048;
98
99 # Write them to a file
100 open(F,'>:utf8',$threebyte) || die "Cannot open $threebyte:$!";
101 print F $str;
102 close(F);
103
104 # Read file back as UTF-8 
105 open(F,'<:encoding(utf-8)',$threebyte) || die "Cannot open $threebyte:$!";
106 my $dstr = <F>;
107 close(F);
108 is($dstr, $str);
109
110 # Try decoding some bad stuff
111 open(F,'>:raw',$threebyte) || die "Cannot open $threebyte:$!";
112 if (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 }
117 close(F);
118
119 open(F,'<:encoding(utf-8)',$threebyte) || die "Cannot open $threebyte:$!";
120 $dstr = join(":", <F>);
121 close(F);
122 if (ord('A') == 193) { # EBCDIC
123     is($dstr, "foo\\x8C\\x80\\x80\\x80bar\n:\\x80foo\n");
124 } else {
125     is($dstr, "foo\\xF0\\x80\\x80\\x80bar\n:\\x80foo\n");
126 }
127
128 # Check that PerlIO::encoding can handle custom encodings that do funny
129 # things with the buffer.
130 use Encode::Encoding;
131 package 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) {
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
146   $buf;
147  }
148  no warnings 'once'; 
149  *decode = *encode;
150 }
151 open my $fh, ">:encoding(extensive)", \$buf;
152 $fh->autoflush;
153 print $fh "doughnut\n";
154 print $fh "quaffee\n";
155 # Print something longer than the buffer that encode() shrunk:
156 print $fh "The beech leaves beech leaves on the beach by the beech.\n";
157 close $fh;
158 is $buf, "doughnut\nquaffee\nThe beech leaves beech leaves on the beach by"
159         ." the beech.\n", 'buffer realloc during encoding';
160 $buf = "Sheila surely shod Sean\nin shoddy shoes.\n";
161 open $fh, "<:encoding(extensive)", \$buf;
162 is join("", <$fh>), "Sheila surely shod Sean\nin shoddy shoes.\n",
163    'buffer realloc during decoding';
164
165 package 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 }
184 open $fh, ">:encoding(cower)", \$buf;
185 $fh->autoflush;
186 print $fh $_ for qw "pumping plum pits";
187 close $fh;
188 is $buf, "pumpingplumpits", 'cowing buffer during encoding';
189 $buf = "pumping\nplum\npits\n";
190 open $fh, "<:encoding(cower)", \$buf;
191 is join("", <$fh>), "pumping\nplum\npits\n",
192   'cowing buffer during decoding';
193
194 package 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.
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.
212 require Config;
213 SKIP: {
214 skip "produces string table warnings", 2
215   if "@{[Config::non_bincompat_options()]}" =~ /\bDEBUGGING\b/
216    && $ENV{PERL_DESTRUCT_LEVEL};
217
218 eval { eval {
219     open my $fh, ">:encoding(globber)", \$buf;
220     print $fh "Agathopous Goodfoot\n";
221     close $fh;
222 }; $e = $@};
223 like $@||$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";
226 open $fh, "<:encoding(globber)", \$buf;
227 my $x = <$fh>;
228 close $fh;
229 is $x, "To hymn him who heard her herd herd\n",
230      'no crash when assigning glob to buffer in decode';
231
232 } # SKIP
233
234 END {
235     1 while unlink($grk, $utf, $fail1, $fail2, $russki, $threebyte);
236 }