ext/PerlIO-scalar/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 use Fcntl qw(SEEK_SET SEEK_CUR SEEK_END); # Not 0, 1, 2 everywhere.
  18
  19 $| = 1;
  20
  21 use Test::More tests => 55;
  22
  23 my $fh;
  24 my $var = "aaa\n";
  25 ok(open($fh,"+<",\$var));
  26
  27 is(<$fh>, $var);
  28
  29 ok(eof($fh));
  30
  31 ok(seek($fh,0,SEEK_SET));
  32 ok(!eof($fh));
  33
  34 ok(print $fh "bbb\n");
  35 is($var, "bbb\n");
  36 $var = "foo\nbar\n";
  37 ok(seek($fh,0,SEEK_SET));
  38 ok(!eof($fh));
  39 is(<$fh>, "foo\n");
  40 ok(close $fh, $!);
  41
  42 # Test that semantics are similar to normal file-based I/O
  43 # Check that ">" clobbers the scalar
  44 $var = "Something";
  45 open $fh, ">", \$var;
  46 is($var, "");
  47 #  Check that file offset set to beginning of scalar
  48 my $off = tell($fh);
  49 is($off, 0);
  50 # Check that writes go where they should and update the offset
  51 $var = "Something";
  52 print $fh "Brea";
  53 $off = tell($fh);
  54 is($off, 4);
  55 is($var, "Breathing");
  56 close $fh;
  57
  58 # Check that ">>" appends to the scalar
  59 $var = "Something ";
  60 open $fh, ">>", \$var;
  61 $off = tell($fh);
  62 is($off, 10);
  63 is($var, "Something ");
  64 #  Check that further writes go to the very end of the scalar
  65 $var .= "else ";
  66 is($var, "Something else ");
  67
  68 $off = tell($fh);
  69 is($off, 10);
  70
  71 print $fh "is here";
  72 is($var, "Something else is here");
  73 close $fh;
  74
  75 # Check that updates to the scalar from elsewhere do not
  76 # cause problems
  77 $var = "line one\nline two\line three\n";
  78 open $fh, "<", \$var;
  79 while (<$fh>) {
  80     $var = "foo";
  81 }
  82 close $fh;
  83 is($var, "foo");
  84
  85 # Check that dup'ing the handle works
  86
  87 $var = '';
  88 open $fh, "+>", \$var;
  89 print $fh "xxx\n";
  90 open $dup,'+<&',$fh;
  91 print $dup "yyy\n";
  92 seek($dup,0,SEEK_SET);
  93 is(<$dup>, "xxx\n");
  94 is(<$dup>, "yyy\n");
  95 close($fh);
  96 close($dup);
  97
  98 open $fh, '<', \42;
  99 is(<$fh>, "42", "reading from non-string scalars");
 100 close $fh;
 101
 102 { package P; sub TIESCALAR {bless{}} sub FETCH { "shazam" } }
 103 tie $p, P; open $fh, '<', \$p;
 104 is(<$fh>, "shazam", "reading from magic scalars");
 105
 106 {
 107     use warnings;
 108     my $warn = 0;
 109     local $SIG{__WARN__} = sub { $warn++ };
 110     open my $fh, '>', \my $scalar;
 111     print $fh "foo";
 112     close $fh;
 113     is($warn, 0, "no warnings when writing to an undefined scalar");
 114 }
 115
 116 {
 117     use warnings;
 118     my $warn = 0;
 119     local $SIG{__WARN__} = sub { $warn++ };
 120     for (1..2) {
 121         open my $fh, '>', \my $scalar;
 122         close $fh;
 123     }
 124     is($warn, 0, "no warnings when reusing a lexical");
 125 }
 126
 127 {
 128     use warnings;
 129     my $warn = 0;
 130     local $SIG{__WARN__} = sub { $warn++ };
 131
 132     my $fetch = 0;
 133     {
 134         package MgUndef;
 135         sub TIESCALAR { bless [] }
 136         sub FETCH { $fetch++; return undef }
 137     }
 138     tie my $scalar, MgUndef;
 139
 140     open my $fh, '<', \$scalar;
 141     close $fh;
 142     is($warn, 0, "no warnings reading a magical undef scalar");
 143     is($fetch, 1, "FETCH only called once");
 144 }
 145
 146 {
 147     use warnings;
 148     my $warn = 0;
 149     local $SIG{__WARN__} = sub { $warn++ };
 150     my $scalar = 3;
 151     undef $scalar;
 152     open my $fh, '<', \$scalar;
 153     close $fh;
 154     is($warn, 0, "no warnings reading an undef, allocated scalar");
 155 }
 156
 157 my $data = "a non-empty PV";
 158 $data = undef;
 159 open(MEM, '<', \$data) or die "Fail: $!\n";
 160 my $x = join '', <MEM>;
 161 is($x, '');
 162
 163 {
 164     # [perl #35929] verify that works with $/ (i.e. test PerlIOScalar_unread)
 165     my $s = <<'EOF';
 166 line A
 167 line B
 168 a third line
 169 EOF
 170     open(F, '<', \$s) or die "Could not open string as a file";
 171     local $/ = "";
 172     my $ln = <F>;
 173     close F;
 174     is($ln, $s, "[perl #35929]");
 175 }
 176
 177 # [perl #40267] PerlIO::scalar doesn't respect readonly-ness
 178 {
 179     ok(!(defined open(F, '>', \undef)), "[perl #40267] - $!");
 180     close F;
 181
 182     my $ro = \43;
 183     ok(!(defined open(F, '>', $ro)), $!);
 184     close F;
 185     # but we can read from it
 186     ok(open(F, '<', $ro), $!);
 187     is(<F>, 43);
 188     close F;
 189 }
 190
 191 {
 192     # Check that we zero fill when needed when seeking,
 193     # and that seeking negative off the string does not do bad things.
 194
 195     my $foo;
 196
 197     ok(open(F, '>', \$foo));
 198
 199     # Seeking forward should zero fill.
 200
 201     ok(seek(F, 50, SEEK_SET));
 202     print F "x";
 203     is(length($foo), 51);
 204     like($foo, qr/^\0{50}x$/);
 205
 206     is(tell(F), 51);
 207     ok(seek(F, 0, SEEK_SET));
 208     is(length($foo), 51);
 209
 210     # Seeking forward again should zero fill but only the new bytes.
 211
 212     ok(seek(F, 100, SEEK_SET));
 213     print F "y";
 214     is(length($foo), 101);
 215     like($foo, qr/^\0{50}x\0{49}y$/);
 216     is(tell(F), 101);
 217
 218     # Seeking back and writing should not zero fill.
 219
 220     ok(seek(F, 75, SEEK_SET));
 221     print F "z";
 222     is(length($foo), 101);
 223     like($foo, qr/^\0{50}x\0{24}z\0{24}y$/);
 224     is(tell(F), 76);
 225
 226     # Seeking negative should not do funny business.
 227
 228     ok(!seek(F,  -50, SEEK_SET), $!);
 229     ok(seek(F, 0, SEEK_SET));
 230     ok(!seek(F,  -50, SEEK_CUR), $!);
 231     ok(!seek(F, -150, SEEK_END), $!);
 232 }
 233