xref: /openbsd/gnu/usr.bin/perl/t/io/open.t (revision 17df1aa7) 
1#!./perl
2
3BEGIN {
4    chdir 't' if -d 't';
5    @INC = '../lib';
6    require './test.pl';
7}
8
9$|  = 1;
10use warnings;
11use Config;
12$Is_MacOS = $^O eq 'MacOS';
13
14plan tests => 108;
15
16my $Perl = which_perl();
17
18my $afile = tempfile();
19{
20    unlink($afile) if -f $afile;
21
22    $! = 0;  # the -f above will set $! if $afile doesn't exist.
23    ok( open(my $f,"+>$afile"),  'open(my $f, "+>...")' );
24
25    binmode $f;
26    ok( -f $afile,              '       its a file');
27    ok( (print $f "SomeData\n"),  '       we can print to it');
28    is( tell($f), 9,            '       tell()' );
29    ok( seek($f,0,0),           '       seek set' );
30
31    $b = <$f>;
32    is( $b, "SomeData\n",       '       readline' );
33    ok( -f $f,                  '       still a file' );
34
35    eval  { die "Message" };
36    like( $@, qr/<\$f> line 1/, '       die message correct' );
37
38    ok( close($f),              '       close()' );
39    ok( unlink($afile),         '       unlink()' );
40}
41
42{
43    ok( open(my $f,'>', $afile),        "open(my \$f, '>', $afile)" );
44    ok( (print $f "a row\n"),           '       print');
45    ok( close($f),                      '       close' );
46    ok( -s $afile < 10,                 '       -s' );
47}
48
49{
50    ok( open(my $f,'>>', $afile),       "open(my \$f, '>>', $afile)" );
51    ok( (print $f "a row\n"),           '       print' );
52    ok( close($f),                      '       close' );
53    ok( -s $afile > 10,                 '       -s'    );
54}
55
56{
57    ok( open(my $f, '<', $afile),       "open(my \$f, '<', $afile)" );
58    my @rows = <$f>;
59    is( scalar @rows, 2,                '       readline, list context' );
60    is( $rows[0], "a row\n",            '       first line read' );
61    is( $rows[1], "a row\n",            '       second line' );
62    ok( close($f),                      '       close' );
63}
64
65{
66    ok( -s $afile < 20,                 '-s' );
67
68    ok( open(my $f, '+<', $afile),      'open +<' );
69    my @rows = <$f>;
70    is( scalar @rows, 2,                '       readline, list context' );
71    ok( seek($f, 0, 1),                 '       seek cur' );
72    ok( (print $f "yet another row\n"), '       print' );
73    ok( close($f),                      '       close' );
74    ok( -s $afile > 20,                 '       -s' );
75
76    unlink($afile);
77}
78{
79    ok( open(my $f, '-|', <<EOC),     'open -|' );
80    $Perl -e "print qq(a row\\n); print qq(another row\\n)"
81EOC
82
83    my @rows = <$f>;
84    is( scalar @rows, 2,                '       readline, list context' );
85    ok( close($f),                      '       close' );
86}
87SKIP: {
88    skip "Output for |- doesn't go to shell on MacOS", 5 if $Is_MacOS;
89
90    ok( open(my $f, '|-', <<EOC),     'open |-' );
91    $Perl -pe "s/^not //"
92EOC
93
94    my @rows = <$f>;
95    my $test = curr_test;
96    print $f "not ok $test - piped in\n";
97    next_test;
98
99    $test = curr_test;
100    print $f "not ok $test - piped in\n";
101    next_test;
102    ok( close($f),                      '       close' );
103    sleep 1;
104    pass('flushing');
105}
106
107
108ok( !eval { open my $f, '<&', $afile; 1; },    '<& on a non-filehandle' );
109like( $@, qr/Bad filehandle:\s+$afile/,          '       right error' );
110
111
112# local $file tests
113{
114    unlink($afile) if -f $afile;
115
116    ok( open(local $f,"+>$afile"),       'open local $f, "+>", ...' );
117    binmode $f;
118
119    ok( -f $afile,                      '       -f' );
120    ok( (print $f "SomeData\n"),        '       print' );
121    is( tell($f), 9,                    '       tell' );
122    ok( seek($f,0,0),                   '       seek set' );
123
124    $b = <$f>;
125    is( $b, "SomeData\n",               '       readline' );
126    ok( -f $f,                          '       still a file' );
127
128    eval  { die "Message" };
129    like( $@, qr/<\$f> line 1/,         '       proper die message' );
130    ok( close($f),                      '       close' );
131
132    unlink($afile);
133}
134
135{
136    ok( open(local $f,'>', $afile),     'open local $f, ">", ...' );
137    ok( (print $f "a row\n"),           '       print');
138    ok( close($f),                      '       close');
139    ok( -s $afile < 10,                 '       -s' );
140}
141
142{
143    ok( open(local $f,'>>', $afile),    'open local $f, ">>", ...' );
144    ok( (print $f "a row\n"),           '       print');
145    ok( close($f),                      '       close');
146    ok( -s $afile > 10,                 '       -s' );
147}
148
149{
150    ok( open(local $f, '<', $afile),    'open local $f, "<", ...' );
151    my @rows = <$f>;
152    is( scalar @rows, 2,                '       readline list context' );
153    ok( close($f),                      '       close' );
154}
155
156ok( -s $afile < 20,                     '       -s' );
157
158{
159    ok( open(local $f, '+<', $afile),  'open local $f, "+<", ...' );
160    my @rows = <$f>;
161    is( scalar @rows, 2,                '       readline list context' );
162    ok( seek($f, 0, 1),                 '       seek cur' );
163    ok( (print $f "yet another row\n"), '       print' );
164    ok( close($f),                      '       close' );
165    ok( -s $afile > 20,                 '       -s' );
166
167    unlink($afile);
168}
169
170{
171    ok( open(local $f, '-|', <<EOC),  'open local $f, "-|", ...' );
172    $Perl -e "print qq(a row\\n); print qq(another row\\n)"
173EOC
174    my @rows = <$f>;
175
176    is( scalar @rows, 2,                '       readline list context' );
177    ok( close($f),                      '       close' );
178}
179
180SKIP: {
181    skip "Output for |- doesn't go to shell on MacOS", 5 if $Is_MacOS;
182
183    ok( open(local $f, '|-', <<EOC),  'open local $f, "|-", ...' );
184    $Perl -pe "s/^not //"
185EOC
186
187    my @rows = <$f>;
188    my $test = curr_test;
189    print $f "not ok $test - piping\n";
190    next_test;
191
192    $test = curr_test;
193    print $f "not ok $test - piping\n";
194    next_test;
195    ok( close($f),                      '       close' );
196    sleep 1;
197    pass("Flush");
198}
199
200
201ok( !eval { open local $f, '<&', $afile; 1 },  'local <& on non-filehandle');
202like( $@, qr/Bad filehandle:\s+$afile/,          '       right error' );
203
204{
205    local *F;
206    for (1..2) {
207	ok( open(F, qq{$Perl -le "print 'ok'"|}), 'open to pipe' );
208	is(scalar <F>, "ok\n",  '       readline');
209	ok( close F,            '       close' );
210    }
211
212    for (1..2) {
213	ok( open(F, "-|", qq{$Perl -le "print 'ok'"}), 'open -|');
214	is( scalar <F>, "ok\n", '       readline');
215	ok( close F,            '       close' );
216    }
217}
218
219
220# other dupping techniques
221{
222    ok( open(my $stdout, ">&", \*STDOUT),       'dup \*STDOUT into lexical fh');
223    ok( open(STDOUT,     ">&", $stdout),        'restore dupped STDOUT from lexical fh');
224
225    {
226	use strict; # the below should not warn
227	ok( open(my $stdout, ">&", STDOUT),         'dup STDOUT into lexical fh');
228    }
229
230    # used to try to open a file [perl #17830]
231    ok( open(my $stdin,  "<&", fileno STDIN),   'dup fileno(STDIN) into lexical fh') or _diag $!;
232}
233
234SKIP: {
235    skip "This perl uses perlio", 1 if $Config{useperlio};
236    skip "miniperl cannot be relied on to load %Errno"
237	if $ENV{PERL_CORE_MINITEST};
238    # Force the reference to %! to be run time by writing ! as {"!"}
239    skip "This system doesn't understand EINVAL", 1
240	unless exists ${"!"}{EINVAL};
241
242    no warnings 'io';
243    ok(!open(F,'>',\my $s) && ${"!"}{EINVAL}, 'open(reference) raises EINVAL');
244}
245
246{
247    ok( !eval { open F, "BAR", "QUUX" },       'Unknown open() mode' );
248    like( $@, qr/\QUnknown open() mode 'BAR'/, '       right error' );
249}
250
251{
252    local $SIG{__WARN__} = sub { $@ = shift };
253
254    sub gimme {
255        my $tmphandle = shift;
256	my $line = scalar <$tmphandle>;
257	warn "gimme";
258	return $line;
259    }
260
261    open($fh0[0], "TEST");
262    gimme($fh0[0]);
263    like($@, qr/<\$fh0\[...\]> line 1\./, "autoviv fh package aelem");
264
265    open($fh1{k}, "TEST");
266    gimme($fh1{k});
267    like($@, qr/<\$fh1{...}> line 1\./, "autoviv fh package helem");
268
269    my @fh2;
270    open($fh2[0], "TEST");
271    gimme($fh2[0]);
272    like($@, qr/<\$fh2\[...\]> line 1\./, "autoviv fh lexical aelem");
273
274    my %fh3;
275    open($fh3{k}, "TEST");
276    gimme($fh3{k});
277    like($@, qr/<\$fh3{...}> line 1\./, "autoviv fh lexical helem");
278}
279
280SKIP: {
281    skip("These tests use perlio", 5) unless $Config{useperlio};
282    my $w;
283    use warnings 'layer';
284    local $SIG{__WARN__} = sub { $w = shift };
285
286    eval { open(F, ">>>", $afile) };
287    like($w, qr/Invalid separator character '>' in PerlIO layer spec/,
288	 "bad open (>>>) warning");
289    like($@, qr/Unknown open\(\) mode '>>>'/,
290	 "bad open (>>>) failure");
291
292    eval { open(F, ">:u", $afile ) };
293    like($w, qr/Unknown PerlIO layer "u"/,
294	 'bad layer ">:u" warning');
295    eval { open(F, "<:u", $afile ) };
296    like($w, qr/Unknown PerlIO layer "u"/,
297	 'bad layer "<:u" warning');
298    eval { open(F, ":c", $afile ) };
299    like($@, qr/Unknown open\(\) mode ':c'/,
300	 'bad layer ":c" failure');
301}
302
303# [perl #28986] "open m" crashes Perl
304
305fresh_perl_like('open m', qr/^Search pattern not terminated at/,
306	{ stderr => 1 }, 'open m test');
307
308fresh_perl_is(
309    'sub f { open(my $fh, "xxx"); $fh = "f"; } f; f;print "ok"',
310    'ok', { stderr => 1 },
311    '#29102: Crash on assignment to lexical filehandle');
312
313# [perl #31767] Using $1 as a filehandle via open $1, "file" doesn't raise
314# an exception
315
316eval { open $99, "foo" };
317like($@, qr/Modification of a read-only value attempted/, "readonly fh");
318