t/io/perlio.t

   1 BEGIN {
   2         chdir 't' if -d 't';
   3         require Config; import Config;
   4     require './test.pl';
   5     set_up_inc('../lib');
   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 dirfd()");
 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