ext/PerlIO/t/scalar.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6     unless (find PerlIO::Layer 'perlio') {
   7         print "1..0 # Skip: not perlio\n";
   8         exit 0;
   9     }
  10     require Config;
  11     if (($Config::Config{'extensions'} !~ m!\bPerlIO/scalar\b!) ){
  12         print "1..0 # Skip -- Perl configured without PerlIO::scalar module\n";
  13         exit 0;
  14     }
  15 }
  16
  17 $| = 1;
  18 print "1..26\n";
  19
  20 my $fh;
  21 my $var = "ok 2\n";
  22 open($fh,"+<",\$var) or print "not ";
  23 print "ok 1\n";
  24 print <$fh>;
  25 print "not " unless eof($fh);
  26 print "ok 3\n";
  27 seek($fh,0,0) or print "not ";
  28 print "not " if eof($fh);
  29 print "ok 4\n";
  30 print "ok 5\n";
  31 print $fh "ok 7\n" or print "not ";
  32 print "ok 6\n";
  33 print $var;
  34 $var = "foo\nbar\n";
  35 seek($fh,0,0) or print "not ";
  36 print "not " if eof($fh);
  37 print "ok 8\n";
  38 print "not " unless <$fh> eq "foo\n";
  39 print "ok 9\n";
  40 my $rv = close $fh;
  41 if (!$rv) {
  42     print "# Close on scalar failed: $!\n";
  43     print "not ";
  44 }
  45 print "ok 10\n";
  46
  47 # Test that semantics are similar to normal file-based I/O
  48 # Check that ">" clobbers the scalar
  49 $var = "Something";
  50 open $fh, ">", \$var;
  51 print "# Got [$var], expect []\n";
  52 print "not " unless $var eq "";
  53 print "ok 11\n";
  54 #  Check that file offset set to beginning of scalar
  55 my $off = tell($fh);
  56 print "# Got $off, expect 0\n";
  57 print "not " unless $off == 0;
  58 print "ok 12\n";
  59 # Check that writes go where they should and update the offset
  60 $var = "Something";
  61 print $fh "Brea";
  62 $off = tell($fh);
  63 print "# Got $off, expect 4\n";
  64 print "not " unless $off == 4;
  65 print "ok 13\n";
  66 print "# Got [$var], expect [Breathing]\n";
  67 print "not " unless $var eq "Breathing";
  68 print "ok 14\n";
  69 close $fh;
  70
  71 # Check that ">>" appends to the scalar
  72 $var = "Something ";
  73 open $fh, ">>", \$var;
  74 $off = tell($fh);
  75 print "# Got $off, expect 10\n";
  76 print "not " unless $off == 10;
  77 print "ok 15\n";
  78 print "# Got [$var], expect [Something ]\n";
  79 print "not " unless $var eq "Something ";
  80 print "ok 16\n";
  81 #  Check that further writes go to the very end of the scalar
  82 $var .= "else ";
  83 print "# Got [$var], expect [Something else ]\n";
  84 print "not " unless $var eq "Something else ";
  85 print "ok 17\n";
  86 $off = tell($fh);
  87 print "# Got $off, expect 10\n";
  88 print "not " unless $off == 10;
  89 print "ok 18\n";
  90 print $fh "is here";
  91 print "# Got [$var], expect [Something else is here]\n";
  92 print "not " unless $var eq "Something else is here";
  93 print "ok 19\n";
  94 close $fh;
  95
  96 # Check that updates to the scalar from elsewhere do not
  97 # cause problems
  98 $var = "line one\nline two\line three\n";
  99 open $fh, "<", \$var;
 100 while (<$fh>) {
 101     $var = "foo";
 102 }
 103 close $fh;
 104 print "# Got [$var], expect [foo]\n";
 105 print "not " unless $var eq "foo";
 106 print "ok 20\n";
 107
 108 # Check that dup'ing the handle works
 109
 110 $var = '';
 111
 112 open $fh, "+>", \$var;
 113 print $fh "ok 21\n";
 114 open $dup,'+<&',$fh;
 115 print $dup "ok 22\n";
 116 seek($dup,0,0);
 117 while (<$dup>) {
 118     print;
 119 }
 120 close($fh);
 121 close($dup);
 122
 123 # Check reading from non-string scalars
 124
 125 open $fh, '<', \42;
 126 print <$fh> eq "42" ? "ok 23\n" : "not ok 23\n";
 127 close $fh;
 128
 129 # reading from magic scalars
 130
 131 { package P; sub TIESCALAR {bless{}} sub FETCH {"ok 24\n"} }
 132 tie $p, P; open $fh, '<', \$p;
 133 print <$fh>;
 134
 135 # don't warn when writing to an undefined scalar
 136
 137 {
 138     use warnings;
 139     my $ok = 1;
 140     local $SIG{__WARN__} = sub { $ok = 0; };
 141     open my $fh, '>', \my $scalar;
 142     print $fh "foo";
 143     close $fh;
 144     print $ok ? "ok 25\n" : "not ok 25\n";
 145 }
 146
 147 my $data = "a non-empty PV";
 148 $data = undef;
 149 open(MEM, '<', \$data) or die "Fail: $!\n";
 150 my $x = join '', <MEM>;
 151 print $x eq '' ? "ok 26\n" : "not ok 26\n";