Don’t LEAVE_with_name("evalcomp") for syntax errors

[perl5.git] / t / op / sysio.t

#!./perl

BEGIN {
  chdir 't' if -d 't';
  @INC = '../lib';
  require './test.pl';
}

plan tests => 48;

open(I, 'op/sysio.t') || die "sysio.t: cannot find myself: $!";

$reopen = ($^O eq 'VMS' ||
           $^O eq 'os2' ||
           $^O eq 'MSWin32' ||
           $^O eq 'NetWare' ||
           $^O eq 'dos' ||
	   $^O eq 'mpeix');

$x = 'abc';

# should not be able to do negative lengths
eval { sysread(I, $x, -1) };
like($@, qr/^Negative length /);

# $x should be intact
is($x, 'abc');

# should not be able to read before the buffer
eval { sysread(I, $x, 1, -4) };
like($@, qr/^Offset outside string /);

# $x should be intact
is($x, 'abc');

$a ='0123456789';

# default offset 0
is(sysread(I, $a, 3), 3);

# $a should be as follows
is($a, '#!.');

# reading past the buffer should zero pad
is(sysread(I, $a, 2, 5), 2);

# the zero pad should be seen now
is($a, "#!.\0\0/p");

# try changing the last two characters of $a
is(sysread(I, $a, 3, -2), 3);

# the last two characters of $a should have changed (into three)
is($a, "#!.\0\0erl");

$outfile = tempfile();

open(O, ">$outfile") || die "sysio.t: cannot write $outfile: $!";

select(O); $|=1; select(STDOUT);

# cannot write negative lengths
eval { syswrite(O, $x, -1) };
like($@, qr/^Negative length /);

# $x still intact
is($x, 'abc');

# $outfile still intact
ok(!-s $outfile);

# should not be able to write from after the buffer
eval { syswrite(O, $x, 1, 4) };
like($@, qr/^Offset outside string /);

# $x still intact
is($x, 'abc');

# but it should be ok to write from the end of the buffer
syswrite(O, $x, 0, 3);
syswrite(O, $x, 1, 3);

# $outfile still intact
if ($reopen) {  # must close file to update EOF marker for stat
  close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
}
ok(!-s $outfile);

# should not be able to write from before the buffer

eval { syswrite(O, $x, 1, -4) };
like($@, qr/^Offset outside string /);

# $x still intact
is($x, 'abc');

# $outfile still intact
if ($reopen) {  # must close file to update EOF marker for stat
  close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
}
ok(!-s $outfile);

# [perl #67912] syswrite prints garbage if called with empty scalar and non-zero offset
eval { my $buf = ''; syswrite(O, $buf, 1, 1) };
like($@, qr/^Offset outside string /);

# $x still intact
is($x, 'abc');

# $outfile still intact
if ($reopen) {  # must close file to update EOF marker for stat
  close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
}
ok(!-s $outfile);

eval { my $buf = 'x'; syswrite(O, $buf, 1, 2) };
like($@, qr/^Offset outside string /);

# $x still intact
is($x, 'abc');

# $outfile still intact
if ($reopen) {  # must close file to update EOF marker for stat
  close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
}
ok(!-s $outfile);

# default offset 0
if (syswrite(O, $a, 2) == 2){
  pass();
} else {
  diag($!);
  fail();
  # most other tests make no sense after e.g. "No space left on device"
  die $!;
}


# $a still intact
is($a, "#!.\0\0erl");

# $outfile should have grown now
if ($reopen) {  # must close file to update EOF marker for stat
  close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
}
is(-s $outfile, 2);

# with offset
is(syswrite(O, $a, 2, 5), 2);

# $a still intact
is($a, "#!.\0\0erl");

# $outfile should have grown now
if ($reopen) {  # must close file to update EOF marker for stat
  close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
}
is(-s $outfile, 4);

# with negative offset and a bit too much length
is(syswrite(O, $a, 5, -3), 3);

# $a still intact
is($a, "#!.\0\0erl");

# $outfile should have grown now
if ($reopen) {  # must close file to update EOF marker for stat
  close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
}
is(-s $outfile, 7);

# with implicit length argument
is(syswrite(O, $x), 3);

# $a still intact
is($x, "abc");

# $outfile should have grown now
if ($reopen) {  # must close file to update EOF marker for stat
  close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
}
is(-s $outfile, 10);

close(O);

open(I, $outfile) || die "sysio.t: cannot read $outfile: $!";

$b = 'xyz';

# reading too much only return as much as available
is(sysread(I, $b, 100), 10);

# this we should have
is($b, '#!ererlabc');

# test sysseek

is(sysseek(I, 2, 0), 2);
sysread(I, $b, 3);
is($b, 'ere');

is(sysseek(I, -2, 1), 3);
sysread(I, $b, 4);
is($b, 'rerl');

ok(sysseek(I, 0, 0) eq '0 but true');

ok(not defined sysseek(I, -1, 1));

close(I);

unlink_all $outfile;

# Check that utf8 IO doesn't upgrade the scalar
open(I, ">$outfile") || die "sysio.t: cannot write $outfile: $!";
# Will skip harmlessly on stdioperl
eval {binmode STDOUT, ":utf8"};
die $@ if $@ and $@ !~ /^IO layers \(like ':utf8'\) unavailable/;

# y diaresis is \w when UTF8
$a = chr 255;

unlike($a, qr/\w/);

syswrite I, $a;

# Should not be upgraded as a side effect of syswrite.
unlike($a, qr/\w/);

# This should work
eval {syswrite I, 2;};
is($@, '');

close(I);
unlink_all $outfile;

chdir('..');

1;

# eof