view release on metacpan or  search on metacpan

t/io/scalar.t  view on Meta::CPAN

    close $fh;
    is($warn, 0, "no warnings when appending to an undefined scalar");
}

{
    use warnings;
    my $warn = 0;
    local $SIG{__WARN__} = sub { $warn++ };
    for (1..2) {
        open my $fh, '>', \my $scalar;
        close $fh;
    }
    is($warn, 0, "no warnings when reusing a lexical");
}

{
    use warnings;
    my $warn = 0;
    local $SIG{__WARN__} = sub { $warn++ };

    my $fetch = 0;
    {
        package MgUndef;
        sub TIESCALAR { bless [] }
        sub FETCH { $fetch++; return undef }
	sub STORE {}
    }
    tie my $scalar, 'MgUndef';

    open my $fh, '<', \$scalar;
    close $fh;
    is($warn, 0, "no warnings reading a magical undef scalar");
    is($fetch, 1, "FETCH only called once");
}

{
    use warnings;
    my $warn = 0;
    local $SIG{__WARN__} = sub { $warn++ };
    my $scalar = 3;
    undef $scalar;
    open my $fh, '<', \$scalar;
    close $fh;
    is($warn, 0, "no warnings reading an undef, allocated scalar");
}

my $data = "a non-empty PV";
$data = undef;
open(MEM, '<', \$data) or die "Fail: $!\n";
my $x = join '', <MEM>;
is($x, '');

{
    # [perl #35929] verify that works with $/ (i.e. test PerlIOScalar_unread)
    my $s = <<'EOF';
line A
line B
a third line
EOF
    open(F, '<', \$s) or die "Could not open string as a file";
    local $/ = "";
    my $ln = <F>;
    close F;
    is($ln, $s, "[perl #35929]");
}

# [perl #40267] PerlIO::scalar doesn't respect readonly-ness
{
    my $warn;
    local $SIG{__WARN__} = sub { $warn = "@_" };
    ok(!(defined open(F, '>', \undef)), "[perl #40267] - $!");
    is($warn, undef, "no warning with warnings off");
    close F;

    use warnings 'layer';
    undef $warn;
    my $ro = \43;
    ok(!(defined open(F, '>', $ro)), $!);
    is($!+0, EACCES, "check we get a read-onlyish error code");
    like($warn, qr/Modification of a read-only value attempted/,
         "check we did warn");
    close F;
    # but we can read from it
    ok(open(F, '<', $ro), $!);
    is(<F>, 43);
    close F;
}

{
    # Check that we zero fill when needed when seeking,
    # and that seeking negative off the string does not do bad things.

    my $foo;

    ok(open(F, '>', \$foo));

    # Seeking forward should zero fill.

    ok(seek(F, 50, SEEK_SET));
    print F "x";
    is(length($foo), 51);
    like($foo, qr/^\0{50}x$/);

    is(tell(F), 51);
    ok(seek(F, 0, SEEK_SET));
    is(length($foo), 51);

    # Seeking forward again should zero fill but only the new bytes.

    ok(seek(F, 100, SEEK_SET));
    print F "y";
    is(length($foo), 101);
    like($foo, qr/^\0{50}x\0{49}y$/);
    is(tell(F), 101);

    # Seeking back and writing should not zero fill.

    ok(seek(F, 75, SEEK_SET));
    print F "z";
    is(length($foo), 101);
    like($foo, qr/^\0{50}x\0{24}z\0{24}y$/);