t/io/perlio.t

   1 BEGIN {
   2         chdir 't' if -d 't';
   3         @INC = '../lib';
   4         require Config; import Config;
   5         unless (find PerlIO::Layer 'perlio') {
   6             print "1..0 # Skip: PerlIO not used\n";
   7             exit 0;
   8         }
   9         require './test.pl';
  10 }
  11
  12 plan tests => 42;
  13
  14 use_ok('PerlIO');
  15
  16 my $txt = "txt$$";
  17 my $bin = "bin$$";
  18 my $utf = "utf$$";
  19 my $nonexistent = "nex$$";
  20
  21 my $txtfh;
  22 my $binfh;
  23 my $utffh;
  24
  25 ok(open($txtfh, ">:crlf", $txt));
  26
  27 ok(open($binfh, ">:raw",  $bin));
  28
  29 ok(open($utffh, ">:utf8", $utf));
  30
  31 print $txtfh "foo\n";
  32 print $txtfh "bar\n";
  33
  34 ok(close($txtfh));
  35
  36 print $binfh "foo\n";
  37 print $binfh "bar\n";
  38
  39 ok(close($binfh));
  40
  41 print $utffh "foo\x{ff}\n";
  42 print $utffh "bar\x{abcd}\n";
  43
  44 ok(close($utffh));
  45
  46 ok(open($txtfh, "<:crlf", $txt));
  47
  48 ok(open($binfh, "<:raw",  $bin));
  49
  50
  51 ok(open($utffh, "<:utf8", $utf));
  52
  53 is(scalar <$txtfh>, "foo\n");
  54 is(scalar <$txtfh>, "bar\n");
  55
  56 is(scalar <$binfh>, "foo\n");
  57 is(scalar <$binfh>, "bar\n");
  58
  59 is(scalar <$utffh>,  "foo\x{ff}\n");
  60 is(scalar <$utffh>, "bar\x{abcd}\n");
  61
  62 ok(eof($txtfh));;
  63
  64 ok(eof($binfh));
  65
  66 ok(eof($utffh));
  67
  68 ok(close($txtfh));
  69
  70 ok(close($binfh));
  71
  72 ok(close($utffh));
  73
  74 # magic temporary file via 3 arg open with undef
  75 {
  76     ok( open(my $x,"+<",undef), 'magic temp file via 3 arg open with undef');
  77     ok( defined fileno($x),     '       fileno' );
  78
  79     select $x;
  80     ok( (print "ok\n"),         '       print' );
  81
  82     select STDOUT;
  83     ok( seek($x,0,0),           '       seek' );
  84     is( scalar <$x>, "ok\n",    '       readline' );
  85     ok( tell($x) >= 3,          '       tell' );
  86
  87     # test magic temp file over STDOUT
  88     open OLDOUT, ">&STDOUT" or die "cannot dup STDOUT: $!";
  89     my $status = open(STDOUT,"+<",undef);
  90     open STDOUT,  ">&OLDOUT" or die "cannot dup OLDOUT: $!";
  91     # report after STDOUT is restored
  92     ok($status, '       re-open STDOUT');
  93     close OLDOUT;
  94
  95     SKIP: {
  96       skip("TMPDIR not honored on this platform", 4)
  97         if !$Config{d_mkstemp}
  98         || $^O eq 'VMS' || $^O eq 'MSwin32' || $^O eq 'os2';
  99       local $ENV{TMPDIR} = $nonexistent;
 100
 101       # hardcoded default temp path
 102       my $perlio_tmp_file_glob = '/tmp/PerlIO_??????';
 103
 104       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');
 105
 106       my $filename = find_filename($x, $perlio_tmp_file_glob);
 107       is($filename, undef, "No tmp files leaked");
 108       unlink $filename if defined $filename;
 109
 110       mkdir $ENV{TMPDIR};
 111       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');
 112
 113       $filename = find_filename($x, $perlio_tmp_file_glob);
 114       is($filename, undef, "No tmp files leaked");
 115       unlink $filename if defined $filename;
 116     }
 117 }
 118
 119 sub find_filename {
 120     my ($fh, @globs) = @_;
 121     my ($dev, $inode) = stat $fh;
 122     die "Can't stat $fh: $!" unless defined $dev;
 123
 124     foreach (@globs) {
 125         foreach my $file (glob $_) {
 126             my ($this_dev, $this_inode) = stat $file;
 127             next unless defined $this_dev;
 128             return $file if $this_dev == $dev && $this_inode == $inode;
 129         }
 130     }
 131     return;
 132 }
 133
 134 # in-memory open
 135 SKIP: {
 136     eval { require PerlIO::scalar };
 137     unless (find PerlIO::Layer 'scalar') {
 138         skip("PerlIO::scalar not found", 9);
 139     }
 140     my $var;
 141     ok( open(my $x,"+<",\$var), 'magic in-memory file via 3 arg open with \\$var');
 142     ok( defined fileno($x),     '       fileno' );
 143
 144     select $x;
 145     ok( (print "ok\n"),         '       print' );
 146
 147     select STDOUT;
 148     ok( seek($x,0,0),           '       seek' );
 149     is( scalar <$x>, "ok\n",    '       readline' );
 150     ok( tell($x) >= 3,          '       tell' );
 151
 152   TODO: {
 153         local $TODO = "broken";
 154
 155         # test in-memory open over STDOUT
 156         open OLDOUT, ">&STDOUT" or die "cannot dup STDOUT: $!";
 157         #close STDOUT;
 158         my $status = open(STDOUT,">",\$var);
 159         my $error = "$!" unless $status; # remember the error
 160         close STDOUT unless $status;
 161         open STDOUT,  ">&OLDOUT" or die "cannot dup OLDOUT: $!";
 162         print "# $error\n" unless $status;
 163         # report after STDOUT is restored
 164         ok($status, '       open STDOUT into in-memory var');
 165
 166         # test in-memory open over STDERR
 167         open OLDERR, ">&STDERR" or die "cannot dup STDERR: $!";
 168         #close STDERR;
 169         ok( open(STDERR,">",\$var), '       open STDERR into in-memory var');
 170         open STDERR,  ">&OLDERR" or die "cannot dup OLDERR: $!";
 171     }
 172
 173
 174 { local $TODO = 'fails well back into 5.8.x';
 175
 176
 177 sub read_fh_and_return_final_rv {
 178         my ($fh) = @_;
 179         my $buf = '';
 180         my $rv;
 181         for (1..3) {
 182                 $rv = read($fh, $buf, 1, length($buf));
 183                 next if $rv;
 184         }
 185         return $rv
 186 }
 187
 188 open(my $no_perlio, '<', \'ab') or die;
 189 open(my $perlio, '<:crlf', \'ab') or die;
 190
 191 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");
 192
 193 close ($perlio);
 194 close ($no_perlio);
 195 }
 196
 197 }
 198
 199
 200 END {
 201     1 while unlink $txt;
 202     1 while unlink $bin;
 203     1 while unlink $utf;
 204     rmdir $nonexistent;
 205 }
 206