source: trunk/essentials/dev-lang/perl/t/op/sysio.t

#!./perl

print "1..42\n";

chdir('op') || chdir('t/op') || die "sysio.t: cannot look for myself: $!";
@INC = '../../lib';

open(I, '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) };
print 'not ' unless ($@ =~ /^Negative length /);
print "ok 1\n";

# $x should be intact
print 'not ' unless ($x eq 'abc');
print "ok 2\n";

# should not be able to read before the buffer
eval { sysread(I, $x, 1, -4) };
print 'not ' unless ($x eq 'abc');
print "ok 3\n";

# $x should be intact
print 'not ' unless ($x eq 'abc');
print "ok 4\n";

$a ='0123456789';

# default offset 0
print 'not ' unless(sysread(I, $a, 3) == 3);
print "ok 5\n";

# $a should be as follows
print 'not ' unless ($a eq '#!.');
print "ok 6\n";

# reading past the buffer should zero pad
print 'not ' unless(sysread(I, $a, 2, 5) == 2);
print "ok 7\n";

# the zero pad should be seen now
print 'not ' unless ($a eq "#!.\0\0/p");
print "ok 8\n";

# try changing the last two characters of $a
print 'not ' unless(sysread(I, $a, 3, -2) == 3);
print "ok 9\n";

# the last two characters of $a should have changed (into three)
print 'not ' unless ($a eq "#!.\0\0erl");
print "ok 10\n";

$outfile = 'sysio.out';

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

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

# cannot write negative lengths
eval { syswrite(O, $x, -1) };
print 'not ' unless ($@ =~ /^Negative length /);
print "ok 11\n";

# $x still intact
print 'not ' unless ($x eq 'abc');
print "ok 12\n";

# $outfile still intact
print 'not ' if (-s $outfile);
print "ok 13\n";

# should not be able to write from after the buffer
eval { syswrite(O, $x, 1, 3) };
print 'not ' unless ($@ =~ /^Offset outside string /);
print "ok 14\n";

# $x still intact
print 'not ' unless ($x eq 'abc');
print "ok 15\n";

# $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: $!";
}
print 'not ' if (-s $outfile);
print "ok 16\n";

# should not be able to write from before the buffer

eval { syswrite(O, $x, 1, -4) };
print 'not ' unless ($@ =~ /^Offset outside string /);
print "ok 17\n";

# $x still intact
print 'not ' unless ($x eq 'abc');
print "ok 18\n";

# $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: $!";
}
print 'not ' if (-s $outfile);
print "ok 19\n";

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


# $a still intact
print 'not ' unless ($a eq "#!.\0\0erl");
print "ok 21\n";

# $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: $!";
}
print 'not ' unless (-s $outfile == 2);
print "ok 22\n";

# with offset
print 'not ' unless (syswrite(O, $a, 2, 5) == 2);
print "ok 23\n";

# $a still intact
print 'not ' unless ($a eq "#!.\0\0erl");
print "ok 24\n";

# $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: $!";
}
print 'not ' unless (-s $outfile == 4);
print "ok 25\n";

# with negative offset and a bit too much length
print 'not ' unless (syswrite(O, $a, 5, -3) == 3);
print "ok 26\n";

# $a still intact
print 'not ' unless ($a eq "#!.\0\0erl");
print "ok 27\n";

# $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: $!";
}
print 'not ' unless (-s $outfile == 7);
print "ok 28\n";

# with implicit length argument
print 'not ' unless (syswrite(O, $x) == 3);
print "ok 29\n";

# $a still intact
print 'not ' unless ($x eq "abc");
print "ok 30\n";

# $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: $!";
}
print 'not ' unless (-s $outfile == 10);
print "ok 31\n";

close(O);

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

$b = 'xyz';

# reading too much only return as much as available
print 'not ' unless (sysread(I, $b, 100) == 10);
print "ok 32\n";
# this we should have
print 'not ' unless ($b eq '#!ererlabc');
print "ok 33\n";

# test sysseek

print 'not ' unless sysseek(I, 2, 0) == 2;
print "ok 34\n";
sysread(I, $b, 3);
print 'not ' unless $b eq 'ere';
print "ok 35\n";

print 'not ' unless sysseek(I, -2, 1) == 3;
print "ok 36\n";
sysread(I, $b, 4);
print 'not ' unless $b eq 'rerl';
print "ok 37\n";

print 'not ' unless sysseek(I, 0, 0) eq '0 but true';
print "ok 38\n";
print 'not ' if defined sysseek(I, -1, 1);
print "ok 39\n";

close(I);

unlink $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;

print $a =~ /\w/ ? "not ok 40\n" : "ok 40\n";

syswrite I, $a;

# Should not be upgraded as a side effect of syswrite.
print $a =~ /\w/ ? "not ok 41\n" : "ok 41\n";

# This should work
eval {syswrite I, 2;};
print $@ eq "" ? "ok 42\n" : "not ok 42 # $@";

close(I);
unlink $outfile;

chdir('..');

1;

# eof