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