This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
18718548d663cb023c41a7e1a452bdda6adda911
[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 $Is_VMS = $^O eq 'VMS';
13 $Is_MacOS = $^O eq 'MacOS';
14
15 plan tests => 106;
16
17 my $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
79 SKIP: {
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)"
84 EOC
85
86     my @rows = <$f>;
87     is( scalar @rows, 2,                '       readline, list context' );
88     ok( close($f),                      '       close' );
89 }
90
91 SKIP: {
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 //"
96 EOC
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
112 ok( !eval { open my $f, '<&', 'afile'; 1; },    '<& on a non-filehandle' );
113 like( $@, 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
160 ok( -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
174 SKIP: {
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)"
179 EOC
180     my @rows = <$f>;
181
182     is( scalar @rows, 2,                '       readline list context' );
183     ok( close($f),                      '       close' );
184 }
185
186 SKIP: {
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 //"
191 EOC
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
207 ok( !eval { open local $f, '<&', 'afile'; 1 },  'local <& on non-filehandle');
208 like( $@, 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
240 SKIP: {
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     
286 SKIP: {
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
311 fresh_perl_like('open m', qr/^Search pattern not terminated at/,
312         { stderr => 1 }, 'open m test');
313