ext/PerlIO/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 }
  10
  11 use Test::More tests => 37;
  12
  13 use_ok('PerlIO');
  14
  15 my $txt = "txt$$";
  16 my $bin = "bin$$";
  17 my $utf = "utf$$";
  18
  19 my $txtfh;
  20 my $binfh;
  21 my $utffh;
  22
  23 ok(open($txtfh, ">:crlf", $txt));
  24
  25 ok(open($binfh, ">:raw",  $bin));
  26
  27 ok(open($utffh, ">:utf8", $utf));
  28
  29 print $txtfh "foo\n";
  30 print $txtfh "bar\n";
  31
  32 ok(close($txtfh));
  33
  34 print $binfh "foo\n";
  35 print $binfh "bar\n";
  36
  37 ok(close($binfh));
  38
  39 print $utffh "foo\x{ff}\n";
  40 print $utffh "bar\x{abcd}\n";
  41
  42 ok(close($utffh));
  43
  44 ok(open($txtfh, "<:crlf", $txt));
  45
  46 ok(open($binfh, "<:raw",  $bin));
  47
  48
  49 ok(open($utffh, "<:utf8", $utf));
  50
  51 is(scalar <$txtfh>, "foo\n");
  52 is(scalar <$txtfh>, "bar\n");
  53
  54 is(scalar <$binfh>, "foo\n");
  55 is(scalar <$binfh>, "bar\n");
  56
  57 is(scalar <$utffh>,  "foo\x{ff}\n");
  58 is(scalar <$utffh>, "bar\x{abcd}\n");
  59
  60 ok(eof($txtfh));;
  61
  62 ok(eof($binfh));
  63
  64 ok(eof($utffh));
  65
  66 ok(close($txtfh));
  67
  68 ok(close($binfh));
  69
  70 ok(close($utffh));
  71
  72 # magic temporary file via 3 arg open with undef
  73 {
  74     ok( open(my $x,"+<",undef), 'magic temp file via 3 arg open with undef');
  75     ok( defined fileno($x),     '       fileno' );
  76
  77     select $x;
  78     ok( (print "ok\n"),         '       print' );
  79
  80     select STDOUT;
  81     ok( seek($x,0,0),           '       seek' );
  82     is( scalar <$x>, "ok\n",    '       readline' );
  83     ok( tell($x) >= 3,          '       tell' );
  84
  85     # test magic temp file over STDOUT
  86     open OLDOUT, ">&STDOUT" or die "cannot dup STDOUT: $!";
  87     my $status = open(STDOUT,"+<",undef);
  88     open STDOUT,  ">&OLDOUT" or die "cannot dup OLDOUT: $!";
  89     # report after STDOUT is restored
  90     ok($status, '       re-open STDOUT');
  91     close OLDOUT;
  92 }
  93
  94 # in-memory open
  95 {
  96     my $var;
  97     ok( open(my $x,"+<",\$var), 'magic in-memory file via 3 arg open with \\$var');
  98     ok( defined fileno($x),     '       fileno' );
  99
 100     select $x;
 101     ok( (print "ok\n"),         '       print' );
 102
 103     select STDOUT;
 104     ok( seek($x,0,0),           '       seek' );
 105     is( scalar <$x>, "ok\n",    '       readline' );
 106     ok( tell($x) >= 3,          '       tell' );
 107
 108   TODO: {
 109         local $TODO = "broken";
 110
 111         # test in-memory open over STDOUT
 112         open OLDOUT, ">&STDOUT" or die "cannot dup STDOUT: $!";
 113         #close STDOUT;
 114         my $status = open(STDOUT,">",\$var);
 115         my $error = "$!" unless $status; # remember the error
 116         close STDOUT unless $status;
 117         open STDOUT,  ">&OLDOUT" or die "cannot dup OLDOUT: $!";
 118         print "# $error\n" unless $status;
 119         # report after STDOUT is restored
 120         ok($status, '       open STDOUT into in-memory var');
 121
 122         # test in-memory open over STDERR
 123         open OLDERR, ">&STDERR" or die "cannot dup STDERR: $!";
 124         #close STDERR;
 125         ok( open(STDERR,">",\$var), '       open STDERR into in-memory var');
 126         open STDERR,  ">&OLDERR" or die "cannot dup OLDERR: $!";
 127     }
 128 }
 129
 130
 131 END {
 132     1 while unlink $txt;
 133     1 while unlink $bin;
 134     1 while unlink $utf;
 135 }
 136