ext/PerlIO-scalar/t/scalar.t

   1 #!./perl
   2
   3 BEGIN {
   4     unless (find PerlIO::Layer 'perlio') {
   5         print "1..0 # Skip: not perlio\n";
   6         exit 0;
   7     }
   8     require Config;
   9     if (($Config::Config{'extensions'} !~ m!\bPerlIO/scalar\b!) ){
  10         print "1..0 # Skip -- Perl configured without PerlIO::scalar module\n";
  11         exit 0;
  12     }
  13 }
  14
  15 use Fcntl qw(SEEK_SET SEEK_CUR SEEK_END); # Not 0, 1, 2 everywhere.
  16
  17 $| = 1;
  18
  19 use Test::More tests => 76;
  20
  21 my $fh;
  22 my $var = "aaa\n";
  23 ok(open($fh,"+<",\$var));
  24
  25 is(<$fh>, $var);
  26
  27 ok(eof($fh));
  28
  29 ok(seek($fh,0,SEEK_SET));
  30 ok(!eof($fh));
  31
  32 ok(print $fh "bbb\n");
  33 is($var, "bbb\n");
  34 $var = "foo\nbar\n";
  35 ok(seek($fh,0,SEEK_SET));
  36 ok(!eof($fh));
  37 is(<$fh>, "foo\n");
  38 ok(close $fh, $!);
  39
  40 # Test that semantics are similar to normal file-based I/O
  41 # Check that ">" clobbers the scalar
  42 $var = "Something";
  43 open $fh, ">", \$var;
  44 is($var, "");
  45 #  Check that file offset set to beginning of scalar
  46 my $off = tell($fh);
  47 is($off, 0);
  48 # Check that writes go where they should and update the offset
  49 $var = "Something";
  50 print $fh "Brea";
  51 $off = tell($fh);
  52 is($off, 4);
  53 is($var, "Breathing");
  54 close $fh;
  55
  56 # Check that ">>" appends to the scalar
  57 $var = "Something ";
  58 open $fh, ">>", \$var;
  59 $off = tell($fh);
  60 is($off, 10);
  61 is($var, "Something ");
  62 #  Check that further writes go to the very end of the scalar
  63 $var .= "else ";
  64 is($var, "Something else ");
  65
  66 $off = tell($fh);
  67 is($off, 10);
  68
  69 print $fh "is here";
  70 is($var, "Something else is here");
  71 close $fh;
  72
  73 # Check that updates to the scalar from elsewhere do not
  74 # cause problems
  75 $var = "line one\nline two\line three\n";
  76 open $fh, "<", \$var;
  77 while (<$fh>) {
  78     $var = "foo";
  79 }
  80 close $fh;
  81 is($var, "foo");
  82
  83 # Check that dup'ing the handle works
  84
  85 $var = '';
  86 open $fh, "+>", \$var;
  87 print $fh "xxx\n";
  88 open $dup,'+<&',$fh;
  89 print $dup "yyy\n";
  90 seek($dup,0,SEEK_SET);
  91 is(<$dup>, "xxx\n");
  92 is(<$dup>, "yyy\n");
  93 close($fh);
  94 close($dup);
  95
  96 open $fh, '<', \42;
  97 is(<$fh>, "42", "reading from non-string scalars");
  98 close $fh;
  99
 100 { package P; sub TIESCALAR {bless{}} sub FETCH { "shazam" } sub STORE {} }
 101 tie $p, P; open $fh, '<', \$p;
 102 is(<$fh>, "shazam", "reading from magic scalars");
 103
 104 {
 105     use warnings;
 106     my $warn = 0;
 107     local $SIG{__WARN__} = sub { $warn++ };
 108     open my $fh, '>', \my $scalar;
 109     print $fh "foo";
 110     close $fh;
 111     is($warn, 0, "no warnings when writing to an undefined scalar");
 112 }
 113
 114 {
 115     use warnings;
 116     my $warn = 0;
 117     local $SIG{__WARN__} = sub { $warn++ };
 118     for (1..2) {
 119         open my $fh, '>', \my $scalar;
 120         close $fh;
 121     }
 122     is($warn, 0, "no warnings when reusing a lexical");
 123 }
 124
 125 {
 126     use warnings;
 127     my $warn = 0;
 128     local $SIG{__WARN__} = sub { $warn++ };
 129
 130     my $fetch = 0;
 131     {
 132         package MgUndef;
 133         sub TIESCALAR { bless [] }
 134         sub FETCH { $fetch++; return undef }
 135         sub STORE {}
 136     }
 137     tie my $scalar, MgUndef;
 138
 139     open my $fh, '<', \$scalar;
 140     close $fh;
 141     is($warn, 0, "no warnings reading a magical undef scalar");
 142     is($fetch, 1, "FETCH only called once");
 143 }
 144
 145 {
 146     use warnings;
 147     my $warn = 0;
 148     local $SIG{__WARN__} = sub { $warn++ };
 149     my $scalar = 3;
 150     undef $scalar;
 151     open my $fh, '<', \$scalar;
 152     close $fh;
 153     is($warn, 0, "no warnings reading an undef, allocated scalar");
 154 }
 155
 156 my $data = "a non-empty PV";
 157 $data = undef;
 158 open(MEM, '<', \$data) or die "Fail: $!\n";
 159 my $x = join '', <MEM>;
 160 is($x, '');
 161
 162 {
 163     # [perl #35929] verify that works with $/ (i.e. test PerlIOScalar_unread)
 164     my $s = <<'EOF';
 165 line A
 166 line B
 167 a third line
 168 EOF
 169     open(F, '<', \$s) or die "Could not open string as a file";
 170     local $/ = "";
 171     my $ln = <F>;
 172     close F;
 173     is($ln, $s, "[perl #35929]");
 174 }
 175
 176 # [perl #40267] PerlIO::scalar doesn't respect readonly-ness
 177 {
 178     ok(!(defined open(F, '>', \undef)), "[perl #40267] - $!");
 179     close F;
 180
 181     my $ro = \43;
 182     ok(!(defined open(F, '>', $ro)), $!);
 183     close F;
 184     # but we can read from it
 185     ok(open(F, '<', $ro), $!);
 186     is(<F>, 43);
 187     close F;
 188 }
 189
 190 {
 191     # Check that we zero fill when needed when seeking,
 192     # and that seeking negative off the string does not do bad things.
 193
 194     my $foo;
 195
 196     ok(open(F, '>', \$foo));
 197
 198     # Seeking forward should zero fill.
 199
 200     ok(seek(F, 50, SEEK_SET));
 201     print F "x";
 202     is(length($foo), 51);
 203     like($foo, qr/^\0{50}x$/);
 204
 205     is(tell(F), 51);
 206     ok(seek(F, 0, SEEK_SET));
 207     is(length($foo), 51);
 208
 209     # Seeking forward again should zero fill but only the new bytes.
 210
 211     ok(seek(F, 100, SEEK_SET));
 212     print F "y";
 213     is(length($foo), 101);
 214     like($foo, qr/^\0{50}x\0{49}y$/);
 215     is(tell(F), 101);
 216
 217     # Seeking back and writing should not zero fill.
 218
 219     ok(seek(F, 75, SEEK_SET));
 220     print F "z";
 221     is(length($foo), 101);
 222     like($foo, qr/^\0{50}x\0{24}z\0{24}y$/);
 223     is(tell(F), 76);
 224
 225     # Seeking negative should not do funny business.
 226
 227     ok(!seek(F,  -50, SEEK_SET), $!);
 228     ok(seek(F, 0, SEEK_SET));
 229     ok(!seek(F,  -50, SEEK_CUR), $!);
 230     ok(!seek(F, -150, SEEK_END), $!);
 231 }
 232
 233 # RT #43789: should respect tied scalar
 234
 235 {
 236     package TS;
 237     my $s;
 238     sub TIESCALAR { bless \my $x }
 239     sub FETCH { $s .= ':F'; ${$_[0]} }
 240     sub STORE { $s .= ":S($_[1])"; ${$_[0]} = $_[1] }
 241
 242     package main;
 243
 244     my $x;
 245     $s = '';
 246     tie $x, 'TS';
 247     my $fh;
 248
 249     ok(open($fh, '>', \$x), 'open-write tied scalar');
 250     $s .= ':O';
 251     print($fh 'ABC');
 252     $s .= ':P';
 253     ok(seek($fh, 0, SEEK_SET));
 254     $s .= ':SK';
 255     print($fh 'DEF');
 256     $s .= ':P';
 257     ok(close($fh), 'close tied scalar - write');
 258     is($s, ':F:S():O:F:S(ABC):P:SK:F:S(DEF):P', 'tied actions - write');
 259     is($x, 'DEF', 'new value preserved');
 260
 261     $x = 'GHI';
 262     $s = '';
 263     ok(open($fh, '+<', \$x), 'open-read tied scalar');
 264     $s .= ':O';
 265     my $buf;
 266     is(read($fh,$buf,2), 2, 'read1');
 267     $s .= ':R';
 268     is($buf, 'GH', 'buf1');
 269     is(read($fh,$buf,2), 1, 'read2');
 270     $s .= ':R';
 271     is($buf, 'I', 'buf2');
 272     is(read($fh,$buf,2), 0, 'read3');
 273     $s .= ':R';
 274     is($buf, '', 'buf3');
 275     ok(close($fh), 'close tied scalar - read');
 276     is($s, ':F:S(GHI):O:F:R:F:R:F:R', 'tied actions - read');
 277 }
 278
 279 # [perl #78716] Seeking beyond the end of the string, then reading
 280 {
 281     my $str = '1234567890';
 282     open my $strIn, '<', \$str;
 283     seek $strIn, 15, 1;
 284     is read($strIn, my $buffer, 5), 0,
 285      'seek beyond end end of string followed by read';
 286 }
 287
 288 # Writing to COW scalars and non-PVs
 289 {
 290     my $bovid = __PACKAGE__;
 291     open my $handel, ">", \$bovid;
 292     print $handel "the COW with the crumpled horn";
 293     is $bovid, "the COW with the crumpled horn", 'writing to COW scalars';
 294
 295     package lrcg { use overload fallback => 1, '""'=>sub { 'chin' } }
 296     seek $handel, 3, 0;
 297     $bovid = bless [], lrcg::;
 298     print $handel 'mney';
 299     is $bovid, 'chimney', 'writing to refs';
 300
 301     seek $handel, 1, 0;
 302     $bovid = 42;  # still has a PV
 303     print $handel 5;
 304     is $bovid, 45, 'writing to numeric scalar';
 305
 306     seek $handel, 1, 0;
 307     undef $bovid;
 308     $bovid = 42;   # just IOK
 309     print $handel 5;
 310     is $bovid, 45, 'writing to numeric scalar';
 311 }
 312
 313 # [perl #92706]
 314 {
 315     open my $fh, "<", \(my $f=*f); seek $fh, 2,1;
 316     pass 'seeking on a glob copy';
 317     open my $fh, "<", \(my $f=*f); seek $fh, -2,2;
 318     pass 'seeking on a glob copy from the end';
 319 }
 320
 321 sub has_trailing_nul(\$) {
 322    my ($ref) = @_;
 323    my $sv = B::svref_2object($ref);
 324    return undef if !$sv->isa('B::PV');
 325
 326    my $cur = $sv->CUR;
 327    my $len = $sv->LEN;
 328    return 0 if $cur >= $len;
 329
 330    my $pv_addr = unpack 'J', pack 'P', $$ref;
 331    my $trailing = unpack 'P', pack 'J', $pv_addr+$cur;
 332    return $trailing eq "\0";
 333 }