This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Make utf8::encode respect magic
[perl5.git] / t / io / perlio.t
CommitLineData
ec28694c
JH
1BEGIN {
2 chdir 't' if -d 't';
3 @INC = '../lib';
4 require Config; import Config;
0214bff6 5 require './test.pl';
e05e9c3d 6 skip_all_without_perlio();
ec28694c
JH
7}
8
4cc39766 9plan tests => 45;
ec28694c 10
51f12e47 11use_ok('PerlIO');
ec28694c
JH
12
13my $txt = "txt$$";
14my $bin = "bin$$";
15my $utf = "utf$$";
26e8050a 16my $nonexistent = "nex$$";
ec28694c
JH
17
18my $txtfh;
19my $binfh;
20my $utffh;
21
51f12e47 22ok(open($txtfh, ">:crlf", $txt));
ec28694c 23
51f12e47 24ok(open($binfh, ">:raw", $bin));
ec28694c 25
51f12e47 26ok(open($utffh, ">:utf8", $utf));
ec28694c
JH
27
28print $txtfh "foo\n";
29print $txtfh "bar\n";
51f12e47
JH
30
31ok(close($txtfh));
ec28694c
JH
32
33print $binfh "foo\n";
34print $binfh "bar\n";
51f12e47
JH
35
36ok(close($binfh));
ec28694c
JH
37
38print $utffh "foo\x{ff}\n";
39print $utffh "bar\x{abcd}\n";
ec28694c 40
51f12e47
JH
41ok(close($utffh));
42
43ok(open($txtfh, "<:crlf", $txt));
44
45ok(open($binfh, "<:raw", $bin));
46
47
48ok(open($utffh, "<:utf8", $utf));
ec28694c 49
51f12e47
JH
50is(scalar <$txtfh>, "foo\n");
51is(scalar <$txtfh>, "bar\n");
ec28694c 52
51f12e47
JH
53is(scalar <$binfh>, "foo\n");
54is(scalar <$binfh>, "bar\n");
ec28694c 55
51f12e47
JH
56is(scalar <$utffh>, "foo\x{ff}\n");
57is(scalar <$utffh>, "bar\x{abcd}\n");
ec28694c 58
51f12e47 59ok(eof($txtfh));;
ec28694c 60
51f12e47 61ok(eof($binfh));
ec28694c 62
51f12e47 63ok(eof($utffh));
ec28694c 64
51f12e47 65ok(close($txtfh));
ec28694c 66
51f12e47 67ok(close($binfh));
ec28694c 68
51f12e47 69ok(close($utffh));
ec28694c 70
51f12e47
JH
71# magic temporary file via 3 arg open with undef
72{
73 ok( open(my $x,"+<",undef), 'magic temp file via 3 arg open with undef');
74 ok( defined fileno($x), ' fileno' );
75
76 select $x;
77 ok( (print "ok\n"), ' print' );
78
79 select STDOUT;
80 ok( seek($x,0,0), ' seek' );
81 is( scalar <$x>, "ok\n", ' readline' );
82 ok( tell($x) >= 3, ' tell' );
83
84 # test magic temp file over STDOUT
85 open OLDOUT, ">&STDOUT" or die "cannot dup STDOUT: $!";
86 my $status = open(STDOUT,"+<",undef);
87 open STDOUT, ">&OLDOUT" or die "cannot dup OLDOUT: $!";
88 # report after STDOUT is restored
89 ok($status, ' re-open STDOUT');
90 close OLDOUT;
26e8050a
NT
91
92 SKIP: {
b1b34a55 93 skip("TMPDIR not honored on this platform", 4)
26e8050a
NT
94 if !$Config{d_mkstemp}
95 || $^O eq 'VMS' || $^O eq 'MSwin32' || $^O eq 'os2';
96 local $ENV{TMPDIR} = $nonexistent;
7299ca58
NC
97
98 # hardcoded default temp path
99 my $perlio_tmp_file_glob = '/tmp/PerlIO_??????';
100
0b99e986 101 ok( open(my $x,"+<",undef), 'TMPDIR honored by magic temp file via 3 arg open with undef - works if TMPDIR points to a non-existent dir');
26e8050a 102
af9379e9
NC
103 my $filename = find_filename($x, $perlio_tmp_file_glob);
104 is($filename, undef, "No tmp files leaked");
03cfa418 105 unlink_all $filename if defined $filename;
7299ca58 106
26e8050a
NT
107 mkdir $ENV{TMPDIR};
108 ok(open(my $x,"+<",undef), 'TMPDIR honored by magic temp file via 3 arg open with undef - works if TMPDIR points to an existent dir');
c1bf414c 109
af9379e9
NC
110 $filename = find_filename($x, $perlio_tmp_file_glob);
111 is($filename, undef, "No tmp files leaked");
03cfa418 112 unlink_all $filename if defined $filename;
26e8050a 113 }
51f12e47
JH
114}
115
af9379e9
NC
116sub find_filename {
117 my ($fh, @globs) = @_;
118 my ($dev, $inode) = stat $fh;
119 die "Can't stat $fh: $!" unless defined $dev;
120
121 foreach (@globs) {
122 foreach my $file (glob $_) {
123 my ($this_dev, $this_inode) = stat $file;
124 next unless defined $this_dev;
125 return $file if $this_dev == $dev && $this_inode == $inode;
126 }
127 }
128 return;
7299ca58
NC
129}
130
51f12e47 131# in-memory open
0cb48d00
RGS
132SKIP: {
133 eval { require PerlIO::scalar };
134 unless (find PerlIO::Layer 'scalar') {
abc55529 135 skip("PerlIO::scalar not found", 11);
0cb48d00 136 }
51f12e47
JH
137 my $var;
138 ok( open(my $x,"+<",\$var), 'magic in-memory file via 3 arg open with \\$var');
139 ok( defined fileno($x), ' fileno' );
140
141 select $x;
142 ok( (print "ok\n"), ' print' );
143
144 select STDOUT;
145 ok( seek($x,0,0), ' seek' );
146 is( scalar <$x>, "ok\n", ' readline' );
147 ok( tell($x) >= 3, ' tell' );
148
149 TODO: {
150 local $TODO = "broken";
151
152 # test in-memory open over STDOUT
153 open OLDOUT, ">&STDOUT" or die "cannot dup STDOUT: $!";
154 #close STDOUT;
155 my $status = open(STDOUT,">",\$var);
156 my $error = "$!" unless $status; # remember the error
3351db02 157 close STDOUT unless $status;
51f12e47
JH
158 open STDOUT, ">&OLDOUT" or die "cannot dup OLDOUT: $!";
159 print "# $error\n" unless $status;
160 # report after STDOUT is restored
161 ok($status, ' open STDOUT into in-memory var');
162
163 # test in-memory open over STDERR
164 open OLDERR, ">&STDERR" or die "cannot dup STDERR: $!";
165 #close STDERR;
166 ok( open(STDERR,">",\$var), ' open STDERR into in-memory var');
167 open STDERR, ">&OLDERR" or die "cannot dup OLDERR: $!";
168 }
ec28694c 169
ec28694c 170
b4c6bb84 171 { local $TODO = 'fails well back into 5.8.x';
86cb0d30
JV
172
173
b4c6bb84 174 sub read_fh_and_return_final_rv {
86cb0d30
JV
175 my ($fh) = @_;
176 my $buf = '';
177 my $rv;
178 for (1..3) {
179 $rv = read($fh, $buf, 1, length($buf));
180 next if $rv;
181 }
182 return $rv
b4c6bb84 183 }
86cb0d30 184
b4c6bb84
FC
185 open(my $no_perlio, '<', \'ab') or die;
186 open(my $perlio, '<:crlf', \'ab') or die;
86cb0d30 187
b4c6bb84
FC
188 is(read_fh_and_return_final_rv($perlio),
189 read_fh_and_return_final_rv($no_perlio),
190 "RT#69332 - perlio should return the same value as nonperlio after EOF");
86cb0d30 191
b4c6bb84
FC
192 close ($perlio);
193 close ($no_perlio);
194 }
86cb0d30 195
b4c6bb84
FC
196 { # [perl #92258]
197 open my $fh, "<", \(my $f = *f);
198 is join("", <$fh>), '*main::f', 'reading from a glob copy';
199 is ref \$f, 'GLOB', 'the glob copy is unaffected';
200 }
71edc894 201
8a71e97e
Z
202}
203
4cc39766
NC
204{
205 # see RT #75722, RT #96008
206 fresh_perl_like(<<'EOP',
207unshift @INC, sub {
208 return undef unless caller eq "main";
209 open my $fh, "<", \1;
210 $fh;
211};
212require Symbol; # doesn't matter whether it exists or not
213EOP
214 qr/\ARecursive call to Perl_load_module in PerlIO_find_layer at/s,
215 {stderr => 1},
216 'Mutal recursion between Perl_load_module and PerlIO_find_layer croaks');
217}
86cb0d30 218
ec28694c 219END {
03cfa418
BG
220 unlink_all $txt;
221 unlink_all $bin;
222 unlink_all $utf;
0b99e986 223 rmdir $nonexistent;
ec28694c
JH
224}
225