This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
ef56ddad305d2ea20858cd9190b1b5eedd890ca1
[perl5.git] / t / io / open.t
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     @INC = '../lib';
6     require './test.pl';
7 }
8
9 $|  = 1;
10 use warnings;
11 use Config;
12
13 plan tests => 122;
14
15 my $Perl = which_perl();
16
17 my $afile = tempfile();
18 {
19     unlink($afile) if -f $afile;
20
21     $! = 0;  # the -f above will set $! if $afile doesn't exist.
22     ok( open(my $f,"+>$afile"),  'open(my $f, "+>...")' );
23
24     binmode $f;
25     ok( -f $afile,              '       its a file');
26     ok( (print $f "SomeData\n"),  '       we can print to it');
27     is( tell($f), 9,            '       tell()' );
28     ok( seek($f,0,0),           '       seek set' );
29
30     $b = <$f>;
31     is( $b, "SomeData\n",       '       readline' );
32     ok( -f $f,                  '       still a file' );
33
34     eval  { die "Message" };
35     like( $@, qr/<\$f> line 1/, '       die message correct' );
36     
37     ok( close($f),              '       close()' );
38     ok( unlink($afile),         '       unlink()' );
39 }
40
41 {
42     ok( open(my $f,'>', $afile),        "open(my \$f, '>', $afile)" );
43     ok( (print $f "a row\n"),           '       print');
44     ok( close($f),                      '       close' );
45     ok( -s $afile < 10,                 '       -s' );
46 }
47
48 {
49     ok( open(my $f,'>>', $afile),       "open(my \$f, '>>', $afile)" );
50     ok( (print $f "a row\n"),           '       print' );
51     ok( close($f),                      '       close' );
52     ok( -s $afile > 10,                 '       -s'    );
53 }
54
55 {
56     ok( open(my $f, '<', $afile),       "open(my \$f, '<', $afile)" );
57     my @rows = <$f>;
58     is( scalar @rows, 2,                '       readline, list context' );
59     is( $rows[0], "a row\n",            '       first line read' );
60     is( $rows[1], "a row\n",            '       second line' );
61     ok( close($f),                      '       close' );
62 }
63
64 {
65     ok( -s $afile < 20,                 '-s' );
66
67     ok( open(my $f, '+<', $afile),      'open +<' );
68     my @rows = <$f>;
69     is( scalar @rows, 2,                '       readline, list context' );
70     ok( seek($f, 0, 1),                 '       seek cur' );
71     ok( (print $f "yet another row\n"), '       print' );
72     ok( close($f),                      '       close' );
73     ok( -s $afile > 20,                 '       -s' );
74
75     unlink($afile);
76 }
77 {
78     ok( open(my $f, '-|', <<EOC),     'open -|' );
79     $Perl -e "print qq(a row\\n); print qq(another row\\n)"
80 EOC
81
82     my @rows = <$f>;
83     is( scalar @rows, 2,                '       readline, list context' );
84     ok( close($f),                      '       close' );
85 }
86 {
87     ok( open(my $f, '|-', <<EOC),     'open |-' );
88     $Perl -pe "s/^not //"
89 EOC
90
91     my @rows = <$f>;
92     my $test = curr_test;
93     print $f "not ok $test - piped in\n";
94     next_test;
95
96     $test = curr_test;
97     print $f "not ok $test - piped in\n";
98     next_test;
99     ok( close($f),                      '       close' );
100     sleep 1;
101     pass('flushing');
102 }
103
104
105 ok( !eval { open my $f, '<&', $afile; 1; },    '<& on a non-filehandle' );
106 like( $@, qr/Bad filehandle:\s+$afile/,          '       right error' );
107
108 ok( !eval { *some_glob = 1; open my $f, '<&', *some_glob; 1; },    '<& on a non-filehandle glob' );
109 like( $@, qr/Bad filehandle:\s+some_glob/,          '       right error' );
110
111 {
112     use utf8;
113     use open qw( :utf8 :std );
114     ok( !eval { use utf8; *ǡfilḛ = 1; open my $f, '<&', *ǡfilḛ; 1; },    '<& on a non-filehandle glob' );
115     like( $@, qr/Bad filehandle:\s+ǡfilḛ/u,          '       right error' );
116 }
117
118 # local $file tests
119 {
120     unlink($afile) if -f $afile;
121
122     ok( open(local $f,"+>$afile"),       'open local $f, "+>", ...' );
123     binmode $f;
124
125     ok( -f $afile,                      '       -f' );
126     ok( (print $f "SomeData\n"),        '       print' );
127     is( tell($f), 9,                    '       tell' );
128     ok( seek($f,0,0),                   '       seek set' );
129
130     $b = <$f>;
131     is( $b, "SomeData\n",               '       readline' );
132     ok( -f $f,                          '       still a file' );
133
134     eval  { die "Message" };
135     like( $@, qr/<\$f> line 1/,         '       proper die message' );
136     ok( close($f),                      '       close' );
137
138     unlink($afile);
139 }
140
141 {
142     ok( open(local $f,'>', $afile),     'open local $f, ">", ...' );
143     ok( (print $f "a row\n"),           '       print');
144     ok( close($f),                      '       close');
145     ok( -s $afile < 10,                 '       -s' );
146 }
147
148 {
149     ok( open(local $f,'>>', $afile),    'open local $f, ">>", ...' );
150     ok( (print $f "a row\n"),           '       print');
151     ok( close($f),                      '       close');
152     ok( -s $afile > 10,                 '       -s' );
153 }
154
155 {
156     ok( open(local $f, '<', $afile),    'open local $f, "<", ...' );
157     my @rows = <$f>;
158     is( scalar @rows, 2,                '       readline list context' );
159     ok( close($f),                      '       close' );
160 }
161
162 ok( -s $afile < 20,                     '       -s' );
163
164 {
165     ok( open(local $f, '+<', $afile),  'open local $f, "+<", ...' );
166     my @rows = <$f>;
167     is( scalar @rows, 2,                '       readline list context' );
168     ok( seek($f, 0, 1),                 '       seek cur' );
169     ok( (print $f "yet another row\n"), '       print' );
170     ok( close($f),                      '       close' );
171     ok( -s $afile > 20,                 '       -s' );
172
173     unlink($afile);
174 }
175
176 {
177     ok( open(local $f, '-|', <<EOC),  'open local $f, "-|", ...' );
178     $Perl -e "print qq(a row\\n); print qq(another row\\n)"
179 EOC
180     my @rows = <$f>;
181
182     is( scalar @rows, 2,                '       readline list context' );
183     ok( close($f),                      '       close' );
184 }
185
186 {
187     ok( open(local $f, '|-', <<EOC),  'open local $f, "|-", ...' );
188     $Perl -pe "s/^not //"
189 EOC
190
191     my @rows = <$f>;
192     my $test = curr_test;
193     print $f "not ok $test - piping\n";
194     next_test;
195
196     $test = curr_test;
197     print $f "not ok $test - piping\n";
198     next_test;
199     ok( close($f),                      '       close' );
200     sleep 1;
201     pass("Flush");
202 }
203
204
205 ok( !eval { open local $f, '<&', $afile; 1 },  'local <& on non-filehandle');
206 like( $@, qr/Bad filehandle:\s+$afile/,          '       right error' );
207
208 {
209     local *F;
210     for (1..2) {
211         ok( open(F, qq{$Perl -le "print 'ok'"|}), 'open to pipe' );
212         is(scalar <F>, "ok\n",  '       readline');
213         ok( close F,            '       close' );
214     }
215
216     for (1..2) {
217         ok( open(F, "-|", qq{$Perl -le "print 'ok'"}), 'open -|');
218         is( scalar <F>, "ok\n", '       readline');
219         ok( close F,            '       close' );
220     }
221 }
222
223
224 # other dupping techniques
225 {
226     ok( open(my $stdout, ">&", \*STDOUT),       'dup \*STDOUT into lexical fh');
227     ok( open(STDOUT,     ">&", $stdout),        'restore dupped STDOUT from lexical fh');
228
229     {
230         use strict; # the below should not warn
231         ok( open(my $stdout, ">&", STDOUT),         'dup STDOUT into lexical fh');
232     }
233
234     # used to try to open a file [perl #17830]
235     ok( open(my $stdin,  "<&", fileno STDIN),   'dup fileno(STDIN) into lexical fh') or _diag $!;
236
237     fileno(STDIN) =~ /(.)/;
238     ok open($stdin, "<&", $1), 'open ... "<&", $magical_fileno',
239         ||  _diag $!;
240 }
241
242 SKIP: {
243     skip "This perl uses perlio", 1 if $Config{useperlio};
244     skip_if_miniperl("miniperl can't rely on loading %Errno", 1);
245     # Force the reference to %! to be run time by writing ! as {"!"}
246     skip "This system doesn't understand EINVAL", 1
247         unless exists ${"!"}{EINVAL};
248
249     no warnings 'io';
250     ok(!open(F,'>',\my $s) && ${"!"}{EINVAL}, 'open(reference) raises EINVAL');
251 }
252
253 {
254     ok( !eval { open F, "BAR", "QUUX" },       'Unknown open() mode' );
255     like( $@, qr/\QUnknown open() mode 'BAR'/, '       right error' );
256 }
257
258 {
259     local $SIG{__WARN__} = sub { $@ = shift };
260
261     sub gimme {
262         my $tmphandle = shift;
263         my $line = scalar <$tmphandle>;
264         warn "gimme";
265         return $line;
266     }
267
268     open($fh0[0], "TEST");
269     gimme($fh0[0]);
270     like($@, qr/<\$fh0\[...\]> line 1\./, "autoviv fh package aelem");
271
272     open($fh1{k}, "TEST");
273     gimme($fh1{k});
274     like($@, qr/<\$fh1\{...}> line 1\./, "autoviv fh package helem");
275
276     my @fh2;
277     open($fh2[0], "TEST");
278     gimme($fh2[0]);
279     like($@, qr/<\$fh2\[...\]> line 1\./, "autoviv fh lexical aelem");
280
281     my %fh3;
282     open($fh3{k}, "TEST");
283     gimme($fh3{k});
284     like($@, qr/<\$fh3\{...}> line 1\./, "autoviv fh lexical helem");
285
286     local $/ = *F;  # used to cause an assertion failure
287     gimme($fh3{k});
288     like($@, qr/<\$fh3\{...}> chunk 2\./,
289         '<...> line 1 when $/ is set to a glob');
290 }
291     
292 SKIP: {
293     skip("These tests use perlio", 5) unless $Config{useperlio};
294     my $w;
295     use warnings 'layer';
296     local $SIG{__WARN__} = sub { $w = shift };
297
298     eval { open(F, ">>>", $afile) };
299     like($w, qr/Invalid separator character '>' in PerlIO layer spec/,
300          "bad open (>>>) warning");
301     like($@, qr/Unknown open\(\) mode '>>>'/,
302          "bad open (>>>) failure");
303
304     eval { open(F, ">:u", $afile ) };
305     like($w, qr/Unknown PerlIO layer "u"/,
306          'bad layer ">:u" warning');
307     eval { open(F, "<:u", $afile ) };
308     like($w, qr/Unknown PerlIO layer "u"/,
309          'bad layer "<:u" warning');
310     eval { open(F, ":c", $afile ) };
311     like($@, qr/Unknown open\(\) mode ':c'/,
312          'bad layer ":c" failure');
313 }
314
315 # [perl #28986] "open m" crashes Perl
316
317 fresh_perl_like('open m', qr/^Search pattern not terminated at/,
318         { stderr => 1 }, 'open m test');
319
320 fresh_perl_is(
321     'sub f { open(my $fh, "xxx"); $fh = "f"; } f; f;print "ok"',
322     'ok', { stderr => 1 },
323     '#29102: Crash on assignment to lexical filehandle');
324
325 # [perl #31767] Using $1 as a filehandle via open $1, "file" doesn't raise
326 # an exception
327
328 eval { open $99, "foo" };
329 like($@, qr/Modification of a read-only value attempted/, "readonly fh");
330 # But we do not want that exception applying to close(), since it does not
331 # modify the fh.
332 eval {
333    no warnings "uninitialized";
334    # make sure $+ is undefined
335    "a" =~ /(b)?/;
336    close $+
337 };
338 is($@, '', 'no "Modification of a read-only value" when closing');
339
340 # [perl#73626] mg_get wasn't run on the pipe arg
341
342 {
343     package p73626;
344     sub TIESCALAR { bless {} }
345     sub FETCH { "$Perl -e 1"}
346
347     tie my $p, 'p73626';
348
349     package main;
350
351     ok( open(my $f, '-|', $p),     'open -| magic');
352 }
353
354 # [perl #77492] Crash when stringifying a glob, a reference to which has
355 #               been opened and written to.
356 fresh_perl_is(
357     '
358       open my $fh, ">", \*STDOUT;
359       print $fh "hello";
360      "".*STDOUT;
361       print "ok";
362       close $fh;
363       unlink \*STDOUT;
364     ',
365     'ok', { stderr => 1 },
366     '[perl #77492]: open $fh, ">", \*glob causes SEGV');
367
368 # [perl #77684] Opening a reference to a glob copy.
369 SKIP: {
370     skip_if_miniperl("no dynamic loading on miniperl, so can't load PerlIO::scalar", 1);
371     my $var = *STDOUT;
372     open my $fh, ">", \$var;
373     print $fh "hello";
374     is $var, "hello", '[perl #77684]: open $fh, ">", \$glob_copy'
375         # when this fails, it leaves an extra file:
376         or unlink \*STDOUT;
377 }
378
379 # check that we can call methods on filehandles auto-magically
380 # and have IO::File loaded for us
381 SKIP: {
382     skip_if_miniperl("no dynamic loading on miniperl, so can't load IO::File", 3);
383     is( $INC{'IO/File.pm'}, undef, "IO::File not loaded" );
384     my $var = "";
385     open my $fh, ">", \$var;
386     ok( eval { $fh->autoflush(1); 1 }, '$fh->autoflush(1) lives' );
387     ok( $INC{'IO/File.pm'}, "IO::File now loaded" );
388 }
389
390 sub _117941 { package _117941; open my $a, "TEST" }
391 delete $::{"_117941::"};
392 _117941();
393 pass("no crash when open autovivifies glob in freed package");