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