This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
t/lib/open.t: Generalize for EBCDIC platforms
[perl5.git] / lib / open.t
CommitLineData
e8c9ad1b 1#!./perl
2
3BEGIN {
4 chdir 't' if -d 't';
5 @INC = '../lib';
bbd5c0f5 6 require Config; import Config;
879ced66 7 require './test.pl';
f2270484 8 require './charset_tools.pl';
e8c9ad1b 9}
10
69dc7e4b 11plan 23;
e8c9ad1b 12
13# open::import expects 'open' as its first argument, but it clashes with open()
14sub import {
15 open::import( 'open', @_ );
16}
17
18# can't use require_ok() here, with a name like 'open'
217f68ed 19ok( require 'open.pm', 'requiring open' );
e8c9ad1b 20
21# this should fail
22eval { import() };
7f17c514 23like( $@, qr/needs explicit list of PerlIO layers/,
217f68ed 24 'import should fail without args' );
e8c9ad1b 25
e8c9ad1b 26# prevent it from loading I18N::Langinfo, so we can test encoding failures
e8c9ad1b 27my $warn;
28local $SIG{__WARN__} = sub {
29 $warn .= shift;
30};
31
7f17c514 32# and it shouldn't be able to find this layer
99ef548b
PM
33$warn = '';
34eval q{ no warnings 'layer'; use open IN => ':macguffin' ; };
35is( $warn, '',
7f17c514 36 'should not warn about unknown layer with bad layer provided' );
99ef548b
PM
37
38$warn = '';
39eval q{ use warnings 'layer'; use open IN => ':macguffin' ; };
7f17c514
RGS
40like( $warn, qr/Unknown PerlIO layer/,
41 'should warn about unknown layer with bad layer provided' );
e8c9ad1b 42
7c0e976d
JH
43# open :locale logic changed since open 1.04, new logic
44# difficult to test portably.
e8c9ad1b 45
7c0e976d 46# see if it sets the magic variables appropriately
e8c9ad1b 47import( 'IN', ':crlf' );
217f68ed 48is( $^H{'open_IN'}, 'crlf', 'should have set crlf layer' );
e8c9ad1b 49
50# it should reset them appropriately, too
51import( 'IN', ':raw' );
217f68ed 52is( $^H{'open_IN'}, 'raw', 'should have reset to raw layer' );
e8c9ad1b 53
1e616cf5 54# it dies if you don't set IN, OUT, or IO
e8c9ad1b 55eval { import( 'sideways', ':raw' ) };
7f17c514 56like( $@, qr/Unknown PerlIO layer class/, 'should croak with unknown class' );
e8c9ad1b 57
58# but it handles them all so well together
1e616cf5
JH
59import( 'IO', ':raw :crlf' );
60is( ${^OPEN}, ":raw :crlf\0:raw :crlf",
7f17c514 61 'should set multi types, multi layer' );
1e616cf5 62is( $^H{'open_IO'}, 'crlf', 'should record last layer set in %^H' );
e8c9ad1b 63
bbd5c0f5 64SKIP: {
44cc5a7c 65 skip("no perlio, no :utf8", 12) unless (find PerlIO::Layer 'perlio');
820c63ad 66
24c43532 67 eval <<EOE;
bbd5c0f5
JH
68 use open ':utf8';
69 open(O, ">utf8");
70 print O chr(0x100);
71 close O;
72 open(I, "<utf8");
e111333b 73 is(ord(<I>), 0x100, ":utf8 single wide character round-trip");
bbd5c0f5 74 close I;
24c43532 75EOE
bbd5c0f5 76
820c63ad
JH
77 open F, ">a";
78 @a = map { chr(1 << ($_ << 2)) } 0..5; # 0x1, 0x10, .., 0x100000
79 unshift @a, chr(0); # ... and a null byte in front just for fun
80 print F @a;
81 close F;
e111333b 82
820c63ad
JH
83 sub systell {
84 use Fcntl 'SEEK_CUR';
85 sysseek($_[0], 0, SEEK_CUR);
86 }
e111333b 87
820c63ad
JH
88 require bytes; # not use
89
90 my $ok;
91
92 open F, "<:utf8", "a";
93 $ok = $a = 0;
94 for (@a) {
95 unless (
96 ($c = sysread(F, $b, 1)) == 1 &&
97 length($b) == 1 &&
98 ord($b) == ord($_) &&
99 systell(F) == ($a += bytes::length($b))
100 ) {
101 print '# ord($_) == ', ord($_), "\n";
102 print '# ord($b) == ', ord($b), "\n";
103 print '# length($b) == ', length($b), "\n";
104 print '# bytes::length($b) == ', bytes::length($b), "\n";
105 print '# systell(F) == ', systell(F), "\n";
106 print '# $a == ', $a, "\n";
107 print '# $c == ', $c, "\n";
108 last;
109 }
110 $ok++;
e111333b 111 }
820c63ad
JH
112 close F;
113 ok($ok == @a,
114 "on :utf8 streams sysread() should work on characters, not bytes");
115
4d70b921
NC
116 sub diagnostics {
117 print '# ord($_) == ', ord($_), "\n";
118 print '# bytes::length($_) == ', bytes::length($_), "\n";
119 print '# systell(G) == ', systell(G), "\n";
120 print '# $a == ', $a, "\n";
121 print '# $c == ', $c, "\n";
e111333b 122 }
820c63ad 123
4d70b921
NC
124
125 my %actions = (
126 syswrite => sub { syswrite G, shift; },
127 'syswrite len' => sub { syswrite G, shift, 1; },
128 'syswrite len pad' => sub {
129 my $temp = shift() . "\243";
130 syswrite G, $temp, 1; },
131 'syswrite off' => sub {
132 my $temp = "\351" . shift();
133 syswrite G, $temp, 1, 1; },
134 'syswrite off pad' => sub {
135 my $temp = "\351" . shift() . "\243";
136 syswrite G, $temp, 1, 1; },
137 );
138
139 foreach my $key (sort keys %actions) {
140 # syswrite() on should work on characters, not bytes
141 open G, ">:utf8", "b";
142
143 print "# $key\n";
144 $ok = $a = 0;
145 for (@a) {
146 unless (
147 ($c = $actions{$key}($_)) == 1 &&
148 systell(G) == ($a += bytes::length($_))
149 ) {
150 diagnostics();
151 last;
152 }
153 $ok++;
820c63ad 154 }
4d70b921
NC
155 close G;
156 ok($ok == @a,
157 "on :utf8 streams syswrite() should work on characters, not bytes");
158
159 open G, "<:utf8", "b";
160 $ok = $a = 0;
161 for (@a) {
162 unless (
163 ($c = sysread(G, $b, 1)) == 1 &&
164 length($b) == 1 &&
165 ord($b) == ord($_) &&
166 systell(G) == ($a += bytes::length($_))
167 ) {
168 print '# ord($_) == ', ord($_), "\n";
169 print '# ord($b) == ', ord($b), "\n";
170 print '# length($b) == ', length($b), "\n";
171 print '# bytes::length($b) == ', bytes::length($b), "\n";
172 print '# systell(G) == ', systell(G), "\n";
173 print '# $a == ', $a, "\n";
174 print '# $c == ', $c, "\n";
175 last;
176 }
177 $ok++;
178 }
179 close G;
180 ok($ok == @a,
181 "checking syswrite() output on :utf8 streams by reading it back in");
e111333b 182 }
e111333b 183}
d4a42255 184SKIP: {
e1c247fd
KW
185 skip("no perlio", 1) unless (find PerlIO::Layer 'perlio');
186 skip("no Encode", 1) unless $Config{extensions} =~ m{\bEncode\b};
e111333b 187
c0abe5aa
RGS
188 eval q[use Encode::Alias;use open ":std", ":locale"];
189 is($@, '', 'can use :std and :locale');
d7a09b41
SR
190}
191
f76f2ef3
TC
192{
193 local $ENV{PERL_UNICODE};
194 delete $ENV{PERL_UNICODE};
195 is runperl(
196 progs => [
197 'use open q\:encoding(UTF-8)\, q-:std-;',
198 'use open q\:encoding(UTF-8)\;',
199 'if(($_ = <STDIN>) eq qq-\x{100}\n-) { print qq-stdin ok\n- }',
200 'else { print qq-got -, join(q q q, map ord, split//), "\n" }',
f2270484
KW
201 'print STDOUT qq-\x{fe}\n-;',
202 'print STDERR qq-\x{fe}\n-;',
f76f2ef3 203 ],
f2270484 204 stdin => byte_utf8a_to_utf8n("\xc4\x80") . "\n",
f76f2ef3
TC
205 stderr => 1,
206 ),
f2270484
KW
207 "stdin ok\n"
208 . byte_utf8a_to_utf8n("\xc3\xbe")
209 . "\n"
210 . byte_utf8a_to_utf8n("\xc3\xbe")
211 . "\n",
f76f2ef3
TC
212 "use open without :std does not affect standard handles",
213 ;
214}
73f1eaca 215
bbd5c0f5
JH
216END {
217 1 while unlink "utf8";
e111333b
JH
218 1 while unlink "a";
219 1 while unlink "b";
bbd5c0f5 220}
1e616cf5
JH
221
222# the test cases beyond __DATA__ need to be executed separately
223
224__DATA__
e8c9ad1b 225$ENV{LC_ALL} = 'nonexistent.euc';
226eval { open::_get_locale_encoding() };
217f68ed 227like( $@, qr/too ambiguous/, 'should die with ambiguous locale encoding' );
1e616cf5
JH
228%%%
229# the special :locale layer
b429a72e 230$ENV{LC_ALL} = $ENV{LANG} = 'ru_RU.KOI8-R';
dbd62f41
JH
231# the :locale will probe the locale environment variables like LANG
232use open OUT => ':locale';
1e616cf5 233open(O, ">koi8");
23bcb45a 234print O chr(0x430); # Unicode CYRILLIC SMALL LETTER A = KOI8-R 0xc1
1e616cf5
JH
235close O;
236open(I, "<koi8");
23bcb45a 237printf "%#x\n", ord(<I>), "\n"; # this should print 0xc1
1e616cf5
JH
238close I;
239%%%