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 => 42;
  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 sub find_filename {
 117     my ($fh, @globs) = @_;
 118     my ($dev, $inode) = stat $fh;
 119     die "Can't stat $fh: $!" unless defined $dev;
 120
 121     foreach (@globs) {
 122         foreach my $file (glob $_) {
 123             my ($this_dev, $this_inode) = stat $file;
 124             next unless defined $this_dev;
 125             return $file if $this_dev == $dev && $this_inode == $inode;
 126         }
 127     }
 128     return;
 129 }
 130
 131 # in-memory open
 132 SKIP: {
 133     eval { require PerlIO::scalar };
 134     unless (find PerlIO::Layer 'scalar') {
 135         skip("PerlIO::scalar not found", 9);
 136     }
 137     my $var;
 138     ok( open(my $x,"+<",\$var), 'magic in-memory file via 3 arg open with \\$var');
 139     ok( defined fileno($x),     '       fileno' );
 140
 141     select $x;
 142     ok( (print "ok\n"),         '       print' );
 143
 144     select STDOUT;
 145     ok( seek($x,0,0),           '       seek' );
 146     is( scalar <$x>, "ok\n",    '       readline' );
 147     ok( tell($x) >= 3,          '       tell' );
 148
 149   TODO: {
 150         local $TODO = "broken";
 151
 152         # test in-memory open over STDOUT
 153         open OLDOUT, ">&STDOUT" or die "cannot dup STDOUT: $!";
 154         #close STDOUT;
 155         my $status = open(STDOUT,">",\$var);
 156         my $error = "$!" unless $status; # remember the error
 157         close STDOUT unless $status;
 158         open STDOUT,  ">&OLDOUT" or die "cannot dup OLDOUT: $!";
 159         print "# $error\n" unless $status;
 160         # report after STDOUT is restored
 161         ok($status, '       open STDOUT into in-memory var');
 162
 163         # test in-memory open over STDERR
 164         open OLDERR, ">&STDERR" or die "cannot dup STDERR: $!";
 165         #close STDERR;
 166         ok( open(STDERR,">",\$var), '       open STDERR into in-memory var');
 167         open STDERR,  ">&OLDERR" or die "cannot dup OLDERR: $!";
 168     }
 169
 170
 171 { local $TODO = 'fails well back into 5.8.x';
 172
 173
 174 sub read_fh_and_return_final_rv {
 175         my ($fh) = @_;
 176         my $buf = '';
 177         my $rv;
 178         for (1..3) {
 179                 $rv = read($fh, $buf, 1, length($buf));
 180                 next if $rv;
 181         }
 182         return $rv
 183 }
 184
 185 open(my $no_perlio, '<', \'ab') or die;
 186 open(my $perlio, '<:crlf', \'ab') or die;
 187
 188 is(read_fh_and_return_final_rv($perlio), read_fh_and_return_final_rv($no_perlio), "RT#69332 - perlio should return the same value as nonperlio after EOF");
 189
 190 close ($perlio);
 191 close ($no_perlio);
 192 }
 193
 194 }
 195
 196
 197 END {
 198     unlink_all $txt;
 199     unlink_all $bin;
 200     unlink_all $utf;
 201     rmdir $nonexistent;
 202 }
 203