Make fileno() builtin work on directory handles
[perl.git] / t / io / perlio.t
1 BEGIN {
2         chdir 't' if -d 't';
3         @INC = '../lib';
4         require Config; import Config;
5         require './test.pl';
6         skip_all_without_perlio();
7 }
8
9 plan tests => 48;
10
11 use_ok('PerlIO');
12
13 my $txt = "txt$$";
14 my $bin = "bin$$";
15 my $utf = "utf$$";
16 my $nonexistent = "nex$$";
17
18 my $txtfh;
19 my $binfh;
20 my $utffh;
21
22 ok(open($txtfh, ">:crlf", $txt));
23
24 ok(open($binfh, ">:raw",  $bin));
25
26 ok(open($utffh, ">:utf8", $utf));
27
28 print $txtfh "foo\n";
29 print $txtfh "bar\n";
30
31 ok(close($txtfh));
32
33 print $binfh "foo\n";
34 print $binfh "bar\n";
35
36 ok(close($binfh));
37
38 print $utffh "foo\x{ff}\n";
39 print $utffh "bar\x{abcd}\n";
40
41 ok(close($utffh));
42
43 ok(open($txtfh, "<:crlf", $txt));
44
45 ok(open($binfh, "<:raw",  $bin));
46
47
48 ok(open($utffh, "<:utf8", $utf));
49
50 is(scalar <$txtfh>, "foo\n");
51 is(scalar <$txtfh>, "bar\n");
52
53 is(scalar <$binfh>, "foo\n");
54 is(scalar <$binfh>, "bar\n");
55
56 is(scalar <$utffh>,  "foo\x{ff}\n");
57 is(scalar <$utffh>, "bar\x{abcd}\n");
58
59 ok(eof($txtfh));;
60
61 ok(eof($binfh));
62
63 ok(eof($utffh));
64
65 ok(close($txtfh));
66
67 ok(close($binfh));
68
69 ok(close($utffh));
70
71 # magic temporary file via 3 arg open with undef
72 {
73     ok( open(my $x,"+<",undef), 'magic temp file via 3 arg open with undef');
74     ok( defined fileno($x),     '       fileno' );
75
76     select $x;
77     ok( (print "ok\n"),         '       print' );
78
79     select STDOUT;
80     ok( seek($x,0,0),           '       seek' );
81     is( scalar <$x>, "ok\n",    '       readline' );
82     ok( tell($x) >= 3,          '       tell' );
83
84     # test magic temp file over STDOUT
85     open OLDOUT, ">&STDOUT" or die "cannot dup STDOUT: $!";
86     my $status = open(STDOUT,"+<",undef);
87     open STDOUT,  ">&OLDOUT" or die "cannot dup OLDOUT: $!";
88     # report after STDOUT is restored
89     ok($status, '       re-open STDOUT');
90     close OLDOUT;
91
92     SKIP: {
93       skip("TMPDIR not honored on this platform", 4)
94         if !$Config{d_mkstemp}
95         || $^O eq 'VMS' || $^O eq 'MSwin32' || $^O eq 'os2';
96       local $ENV{TMPDIR} = $nonexistent;
97
98       # hardcoded default temp path
99       my $perlio_tmp_file_glob = '/tmp/PerlIO_??????';
100
101       ok( open(my $x,"+<",undef), 'TMPDIR honored by magic temp file via 3 arg open with undef - works if TMPDIR points to a non-existent dir');
102
103       my $filename = find_filename($x, $perlio_tmp_file_glob);
104       is($filename, undef, "No tmp files leaked");
105       unlink_all $filename if defined $filename;
106
107       mkdir $ENV{TMPDIR};
108       ok(open(my $x,"+<",undef), 'TMPDIR honored by magic temp file via 3 arg open with undef - works if TMPDIR points to an existent dir');
109
110       $filename = find_filename($x, $perlio_tmp_file_glob);
111       is($filename, undef, "No tmp files leaked");
112       unlink_all $filename if defined $filename;
113     }
114 }
115
116 # fileno() for directory handles, on supported platforms
117 SKIP: {
118     opendir my $dh, "io"
119         or die "Huh? Can't open directory 'io' containing this file: $!\n";
120     local $! = 0;
121     my $fd = fileno $dh;
122     my $errno = 0 + $!;
123     closedir $dh
124         or die "Huh? Can't close freshly-opened directory handle: $!\n";
125     if ($Config{d_dirfd} || $Config{d_dir_dd_fd}) {
126         ok(defined $fd, "fileno(DIRHANDLE) is defined under dirfd()")
127             or skip("directory fd was undefined", 1);
128         like($fd, qr/\A\d+\z/a,
129              "fileno(DIRHANDLE) yields non-negative int under dirfd()");
130     }
131     else {
132         ok(!defined $fd, "fileno(DIRHANDLE) is undef when no dirfd()");
133         isnt($errno, 0, "fileno(DIRHANDLE) sets errno when no dirfs()");
134     }
135 }
136
137 sub find_filename {
138     my ($fh, @globs) = @_;
139     my ($dev, $inode) = stat $fh;
140     die "Can't stat $fh: $!" unless defined $dev;
141
142     foreach (@globs) {
143         foreach my $file (glob $_) {
144             my ($this_dev, $this_inode) = stat $file;
145             next unless defined $this_dev;
146             return $file if $this_dev == $dev && $this_inode == $inode;
147         }
148     }
149     return;
150 }
151
152 # in-memory open
153 SKIP: {
154     eval { require PerlIO::scalar };
155     unless (find PerlIO::Layer 'scalar') {
156         skip("PerlIO::scalar not found", 11);
157     }
158     my $var;
159     ok( open(my $x,"+<",\$var), 'magic in-memory file via 3 arg open with \\$var');
160     ok( defined fileno($x),     '       fileno' );
161
162     select $x;
163     ok( (print "ok\n"),         '       print' );
164
165     select STDOUT;
166     ok( seek($x,0,0),           '       seek' );
167     is( scalar <$x>, "ok\n",    '       readline' );
168     ok( tell($x) >= 3,          '       tell' );
169
170   TODO: {
171         local $TODO = "broken";
172
173         # test in-memory open over STDOUT
174         open OLDOUT, ">&STDOUT" or die "cannot dup STDOUT: $!";
175         #close STDOUT;
176         my $status = open(STDOUT,">",\$var);
177         my $error = "$!" unless $status; # remember the error
178         close STDOUT unless $status;
179         open STDOUT,  ">&OLDOUT" or die "cannot dup OLDOUT: $!";
180         print "# $error\n" unless $status;
181         # report after STDOUT is restored
182         ok($status, '       open STDOUT into in-memory var');
183
184         # test in-memory open over STDERR
185         open OLDERR, ">&STDERR" or die "cannot dup STDERR: $!";
186         #close STDERR;
187         ok( open(STDERR,">",\$var), '       open STDERR into in-memory var');
188         open STDERR,  ">&OLDERR" or die "cannot dup OLDERR: $!";
189     }
190
191
192     { local $TODO = 'fails well back into 5.8.x';
193
194         
195       sub read_fh_and_return_final_rv {
196         my ($fh) = @_;
197         my $buf = '';
198         my $rv;
199         for (1..3) {
200                 $rv = read($fh, $buf, 1, length($buf));
201                 next if $rv;
202         }
203         return $rv
204       }
205
206       open(my $no_perlio, '<', \'ab') or die; 
207       open(my $perlio, '<:crlf', \'ab') or die; 
208
209       is(read_fh_and_return_final_rv($perlio),
210          read_fh_and_return_final_rv($no_perlio),
211         "RT#69332 - perlio should return the same value as nonperlio after EOF");
212
213       close ($perlio);
214       close ($no_perlio);
215     }
216
217     { # [perl #92258]
218         open my $fh, "<", \(my $f = *f);
219         is join("", <$fh>), '*main::f', 'reading from a glob copy';
220         is ref \$f, 'GLOB', 'the glob copy is unaffected';
221     }
222
223 }
224
225 {
226     # see RT #75722, RT #96008
227     fresh_perl_like(<<'EOP',
228 unshift @INC, sub {
229     return undef unless caller eq "main";
230     open my $fh, "<", \1;
231     $fh;
232 };
233 require Symbol; # doesn't matter whether it exists or not
234 EOP
235                     qr/\ARecursive call to Perl_load_module in PerlIO_find_layer at/s,
236                     {stderr => 1},
237                     'Mutal recursion between Perl_load_module and PerlIO_find_layer croaks');
238 }
239
240 {
241     # RT #119287
242     $main::PerlIO_code_injection = 0;
243     local $SIG{__WARN__} = sub {};
244     PerlIO->import('via; $main::PerlIO_code_injection = 1');
245     ok !$main::PerlIO_code_injection, "Can't inject code via PerlIO->import";
246 }
247
248 END {
249     unlink_all $txt;
250     unlink_all $bin;
251     unlink_all $utf;
252     rmdir $nonexistent;
253 }
254