Deprecate literal unescaped "{" in regexes.
[perl.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 => 119;
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
238 SKIP: {
239     skip "This perl uses perlio", 1 if $Config{useperlio};
240     skip_if_miniperl("miniperl can't rely on loading %Errno", 1);
241     # Force the reference to %! to be run time by writing ! as {"!"}
242     skip "This system doesn't understand EINVAL", 1
243         unless exists ${"!"}{EINVAL};
244
245     no warnings 'io';
246     ok(!open(F,'>',\my $s) && ${"!"}{EINVAL}, 'open(reference) raises EINVAL');
247 }
248
249 {
250     ok( !eval { open F, "BAR", "QUUX" },       'Unknown open() mode' );
251     like( $@, qr/\QUnknown open() mode 'BAR'/, '       right error' );
252 }
253
254 {
255     local $SIG{__WARN__} = sub { $@ = shift };
256
257     sub gimme {
258         my $tmphandle = shift;
259         my $line = scalar <$tmphandle>;
260         warn "gimme";
261         return $line;
262     }
263
264     open($fh0[0], "TEST");
265     gimme($fh0[0]);
266     like($@, qr/<\$fh0\[...\]> line 1\./, "autoviv fh package aelem");
267
268     open($fh1{k}, "TEST");
269     gimme($fh1{k});
270     like($@, qr/<\$fh1\{...}> line 1\./, "autoviv fh package helem");
271
272     my @fh2;
273     open($fh2[0], "TEST");
274     gimme($fh2[0]);
275     like($@, qr/<\$fh2\[...\]> line 1\./, "autoviv fh lexical aelem");
276
277     my %fh3;
278     open($fh3{k}, "TEST");
279     gimme($fh3{k});
280     like($@, qr/<\$fh3\{...}> line 1\./, "autoviv fh lexical helem");
281 }
282     
283 SKIP: {
284     skip("These tests use perlio", 5) unless $Config{useperlio};
285     my $w;
286     use warnings 'layer';
287     local $SIG{__WARN__} = sub { $w = shift };
288
289     eval { open(F, ">>>", $afile) };
290     like($w, qr/Invalid separator character '>' in PerlIO layer spec/,
291          "bad open (>>>) warning");
292     like($@, qr/Unknown open\(\) mode '>>>'/,
293          "bad open (>>>) failure");
294
295     eval { open(F, ">:u", $afile ) };
296     like($w, qr/Unknown PerlIO layer "u"/,
297          'bad layer ">:u" warning');
298     eval { open(F, "<:u", $afile ) };
299     like($w, qr/Unknown PerlIO layer "u"/,
300          'bad layer "<:u" warning');
301     eval { open(F, ":c", $afile ) };
302     like($@, qr/Unknown open\(\) mode ':c'/,
303          'bad layer ":c" failure');
304 }
305
306 # [perl #28986] "open m" crashes Perl
307
308 fresh_perl_like('open m', qr/^Search pattern not terminated at/,
309         { stderr => 1 }, 'open m test');
310
311 fresh_perl_is(
312     'sub f { open(my $fh, "xxx"); $fh = "f"; } f; f;print "ok"',
313     'ok', { stderr => 1 },
314     '#29102: Crash on assignment to lexical filehandle');
315
316 # [perl #31767] Using $1 as a filehandle via open $1, "file" doesn't raise
317 # an exception
318
319 eval { open $99, "foo" };
320 like($@, qr/Modification of a read-only value attempted/, "readonly fh");
321 # But we do not want that exception applying to close(), since it does not
322 # modify the fh.
323 eval {
324    no warnings "uninitialized";
325    # make sure $+ is undefined
326    "a" =~ /(b)?/;
327    close $+
328 };
329 is($@, '', 'no "Modification of a read-only value" when closing');
330
331 # [perl#73626] mg_get wasn't run on the pipe arg
332
333 {
334     package p73626;
335     sub TIESCALAR { bless {} }
336     sub FETCH { "$Perl -e 1"}
337
338     tie my $p, 'p73626';
339
340     package main;
341
342     ok( open(my $f, '-|', $p),     'open -| magic');
343 }
344
345 # [perl #77492] Crash when stringifying a glob, a reference to which has
346 #               been opened and written to.
347 fresh_perl_is(
348     '
349       open my $fh, ">", \*STDOUT;
350       print $fh "hello";
351      "".*STDOUT;
352       print "ok";
353       close $fh;
354       unlink \*STDOUT;
355     ',
356     'ok', { stderr => 1 },
357     '[perl #77492]: open $fh, ">", \*glob causes SEGV');
358
359 # [perl #77684] Opening a reference to a glob copy.
360 SKIP: {
361     skip_if_miniperl("no dynamic loading on miniperl, so can't load PerlIO::scalar", 1);
362     my $var = *STDOUT;
363     open my $fh, ">", \$var;
364     print $fh "hello";
365     is $var, "hello", '[perl #77684]: open $fh, ">", \$glob_copy'
366         # when this fails, it leaves an extra file:
367         or unlink \*STDOUT;
368 }
369
370 # check that we can call methods on filehandles auto-magically
371 # and have IO::File loaded for us
372 SKIP: {
373     skip_if_miniperl("no dynamic loading on miniperl, so can't load IO::File", 3);
374     is( $INC{'IO/File.pm'}, undef, "IO::File not loaded" );
375     my $var = "";
376     open my $fh, ">", \$var;
377     ok( eval { $fh->autoflush(1); 1 }, '$fh->autoflush(1) lives' );
378     ok( $INC{'IO/File.pm'}, "IO::File now loaded" );
379 }