Move the require './test.pl' to the end of t/comp/hints.t
[p5sagit/p5-mst-13.2.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 => 108;
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
109 # local $file tests
110 {
111     unlink($afile) if -f $afile;
112
113     ok( open(local $f,"+>$afile"),       'open local $f, "+>", ...' );
114     binmode $f;
115
116     ok( -f $afile,                      '       -f' );
117     ok( (print $f "SomeData\n"),        '       print' );
118     is( tell($f), 9,                    '       tell' );
119     ok( seek($f,0,0),                   '       seek set' );
120
121     $b = <$f>;
122     is( $b, "SomeData\n",               '       readline' );
123     ok( -f $f,                          '       still a file' );
124
125     eval  { die "Message" };
126     like( $@, qr/<\$f> line 1/,         '       proper die message' );
127     ok( close($f),                      '       close' );
128
129     unlink($afile);
130 }
131
132 {
133     ok( open(local $f,'>', $afile),     'open local $f, ">", ...' );
134     ok( (print $f "a row\n"),           '       print');
135     ok( close($f),                      '       close');
136     ok( -s $afile < 10,                 '       -s' );
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     my @rows = <$f>;
149     is( scalar @rows, 2,                '       readline list context' );
150     ok( close($f),                      '       close' );
151 }
152
153 ok( -s $afile < 20,                     '       -s' );
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( seek($f, 0, 1),                 '       seek cur' );
160     ok( (print $f "yet another row\n"), '       print' );
161     ok( close($f),                      '       close' );
162     ok( -s $afile > 20,                 '       -s' );
163
164     unlink($afile);
165 }
166
167 {
168     ok( open(local $f, '-|', <<EOC),  'open local $f, "-|", ...' );
169     $Perl -e "print qq(a row\\n); print qq(another row\\n)"
170 EOC
171     my @rows = <$f>;
172
173     is( scalar @rows, 2,                '       readline list context' );
174     ok( close($f),                      '       close' );
175 }
176
177 {
178     ok( open(local $f, '|-', <<EOC),  'open local $f, "|-", ...' );
179     $Perl -pe "s/^not //"
180 EOC
181
182     my @rows = <$f>;
183     my $test = curr_test;
184     print $f "not ok $test - piping\n";
185     next_test;
186
187     $test = curr_test;
188     print $f "not ok $test - piping\n";
189     next_test;
190     ok( close($f),                      '       close' );
191     sleep 1;
192     pass("Flush");
193 }
194
195
196 ok( !eval { open local $f, '<&', $afile; 1 },  'local <& on non-filehandle');
197 like( $@, qr/Bad filehandle:\s+$afile/,          '       right error' );
198
199 {
200     local *F;
201     for (1..2) {
202         ok( open(F, qq{$Perl -le "print 'ok'"|}), 'open to pipe' );
203         is(scalar <F>, "ok\n",  '       readline');
204         ok( close F,            '       close' );
205     }
206
207     for (1..2) {
208         ok( open(F, "-|", qq{$Perl -le "print 'ok'"}), 'open -|');
209         is( scalar <F>, "ok\n", '       readline');
210         ok( close F,            '       close' );
211     }
212 }
213
214
215 # other dupping techniques
216 {
217     ok( open(my $stdout, ">&", \*STDOUT),       'dup \*STDOUT into lexical fh');
218     ok( open(STDOUT,     ">&", $stdout),        'restore dupped STDOUT from lexical fh');
219
220     {
221         use strict; # the below should not warn
222         ok( open(my $stdout, ">&", STDOUT),         'dup STDOUT into lexical fh');
223     }
224
225     # used to try to open a file [perl #17830]
226     ok( open(my $stdin,  "<&", fileno STDIN),   'dup fileno(STDIN) into lexical fh') or _diag $!;
227 }
228
229 SKIP: {
230     skip "This perl uses perlio", 1 if $Config{useperlio};
231     skip "miniperl cannot be relied on to load %Errno"
232         if $ENV{PERL_CORE_MINITEST};
233     # Force the reference to %! to be run time by writing ! as {"!"}
234     skip "This system doesn't understand EINVAL", 1
235         unless exists ${"!"}{EINVAL};
236
237     no warnings 'io';
238     ok(!open(F,'>',\my $s) && ${"!"}{EINVAL}, 'open(reference) raises EINVAL');
239 }
240
241 {
242     ok( !eval { open F, "BAR", "QUUX" },       'Unknown open() mode' );
243     like( $@, qr/\QUnknown open() mode 'BAR'/, '       right error' );
244 }
245
246 {
247     local $SIG{__WARN__} = sub { $@ = shift };
248
249     sub gimme {
250         my $tmphandle = shift;
251         my $line = scalar <$tmphandle>;
252         warn "gimme";
253         return $line;
254     }
255
256     open($fh0[0], "TEST");
257     gimme($fh0[0]);
258     like($@, qr/<\$fh0\[...\]> line 1\./, "autoviv fh package aelem");
259
260     open($fh1{k}, "TEST");
261     gimme($fh1{k});
262     like($@, qr/<\$fh1{...}> line 1\./, "autoviv fh package helem");
263
264     my @fh2;
265     open($fh2[0], "TEST");
266     gimme($fh2[0]);
267     like($@, qr/<\$fh2\[...\]> line 1\./, "autoviv fh lexical aelem");
268
269     my %fh3;
270     open($fh3{k}, "TEST");
271     gimme($fh3{k});
272     like($@, qr/<\$fh3{...}> line 1\./, "autoviv fh lexical helem");
273 }
274     
275 SKIP: {
276     skip("These tests use perlio", 5) unless $Config{useperlio};
277     my $w;
278     use warnings 'layer';
279     local $SIG{__WARN__} = sub { $w = shift };
280
281     eval { open(F, ">>>", $afile) };
282     like($w, qr/Invalid separator character '>' in PerlIO layer spec/,
283          "bad open (>>>) warning");
284     like($@, qr/Unknown open\(\) mode '>>>'/,
285          "bad open (>>>) failure");
286
287     eval { open(F, ">:u", $afile ) };
288     like($w, qr/Unknown PerlIO layer "u"/,
289          'bad layer ">:u" warning');
290     eval { open(F, "<:u", $afile ) };
291     like($w, qr/Unknown PerlIO layer "u"/,
292          'bad layer "<:u" warning');
293     eval { open(F, ":c", $afile ) };
294     like($@, qr/Unknown open\(\) mode ':c'/,
295          'bad layer ":c" failure');
296 }
297
298 # [perl #28986] "open m" crashes Perl
299
300 fresh_perl_like('open m', qr/^Search pattern not terminated at/,
301         { stderr => 1 }, 'open m test');
302
303 fresh_perl_is(
304     'sub f { open(my $fh, "xxx"); $fh = "f"; } f; f;print "ok"',
305     'ok', { stderr => 1 },
306     '#29102: Crash on assignment to lexical filehandle');
307
308 # [perl #31767] Using $1 as a filehandle via open $1, "file" doesn't raise
309 # an exception
310
311 eval { open $99, "foo" };
312 like($@, qr/Modification of a read-only value attempted/, "readonly fh");