t/op/sysio.t

   1 #!./perl
   2
   3 BEGIN {
   4   chdir('op') || chdir('t/op') || die "sysio.t: cannot look for myself: $!";
   5   @INC = '../../lib';
   6   require '../test.pl';
   7 }
   8
   9 plan tests => 48;
  10
  11 open(I, 'sysio.t') || die "sysio.t: cannot find myself: $!";
  12
  13 $reopen = ($^O eq 'VMS' ||
  14            $^O eq 'os2' ||
  15            $^O eq 'MSWin32' ||
  16            $^O eq 'NetWare' ||
  17            $^O eq 'dos' ||
  18            $^O eq 'mpeix');
  19
  20 $x = 'abc';
  21
  22 # should not be able to do negative lengths
  23 eval { sysread(I, $x, -1) };
  24 like($@, qr/^Negative length /);
  25
  26 # $x should be intact
  27 is($x, 'abc');
  28
  29 # should not be able to read before the buffer
  30 eval { sysread(I, $x, 1, -4) };
  31 like($@, qr/^Offset outside string /);
  32
  33 # $x should be intact
  34 is($x, 'abc');
  35
  36 $a ='0123456789';
  37
  38 # default offset 0
  39 is(sysread(I, $a, 3), 3);
  40
  41 # $a should be as follows
  42 is($a, '#!.');
  43
  44 # reading past the buffer should zero pad
  45 is(sysread(I, $a, 2, 5), 2);
  46
  47 # the zero pad should be seen now
  48 is($a, "#!.\0\0/p");
  49
  50 # try changing the last two characters of $a
  51 is(sysread(I, $a, 3, -2), 3);
  52
  53 # the last two characters of $a should have changed (into three)
  54 is($a, "#!.\0\0erl");
  55
  56 $outfile = tempfile();
  57
  58 open(O, ">$outfile") || die "sysio.t: cannot write $outfile: $!";
  59
  60 select(O); $|=1; select(STDOUT);
  61
  62 # cannot write negative lengths
  63 eval { syswrite(O, $x, -1) };
  64 like($@, qr/^Negative length /);
  65
  66 # $x still intact
  67 is($x, 'abc');
  68
  69 # $outfile still intact
  70 ok(!-s $outfile);
  71
  72 # should not be able to write from after the buffer
  73 eval { syswrite(O, $x, 1, 3) };
  74 like($@, qr/^Offset outside string /);
  75
  76 # $x still intact
  77 is($x, 'abc');
  78
  79 # $outfile still intact
  80 if ($reopen) {  # must close file to update EOF marker for stat
  81   close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
  82 }
  83 ok(!-s $outfile);
  84
  85 # should not be able to write from before the buffer
  86
  87 eval { syswrite(O, $x, 1, -4) };
  88 like($@, qr/^Offset outside string /);
  89
  90 # $x still intact
  91 is($x, 'abc');
  92
  93 # $outfile still intact
  94 if ($reopen) {  # must close file to update EOF marker for stat
  95   close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
  96 }
  97 ok(!-s $outfile);
  98
  99 # [perl #67912] syswrite prints garbage if called with empty scalar and non-zero offset
 100 eval { my $buf = ''; syswrite(O, $buf, 1, 0) };
 101 like($@, qr/^Offset outside string /);
 102
 103 # $x still intact
 104 is($x, 'abc');
 105
 106 # $outfile still intact
 107 if ($reopen) {  # must close file to update EOF marker for stat
 108   close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
 109 }
 110 ok(!-s $outfile);
 111
 112 eval { my $buf = 'x'; syswrite(O, $buf, 1, 1) };
 113 like($@, qr/^Offset outside string /);
 114
 115 # $x still intact
 116 is($x, 'abc');
 117
 118 # $outfile still intact
 119 if ($reopen) {  # must close file to update EOF marker for stat
 120   close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
 121 }
 122 ok(!-s $outfile);
 123
 124 # default offset 0
 125 if (syswrite(O, $a, 2) == 2){
 126   pass();
 127 } else {
 128   diag($!);
 129   fail();
 130   # most other tests make no sense after e.g. "No space left on device"
 131   die $!;
 132 }
 133
 134
 135 # $a still intact
 136 is($a, "#!.\0\0erl");
 137
 138 # $outfile should have grown now
 139 if ($reopen) {  # must close file to update EOF marker for stat
 140   close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
 141 }
 142 is(-s $outfile, 2);
 143
 144 # with offset
 145 is(syswrite(O, $a, 2, 5), 2);
 146
 147 # $a still intact
 148 is($a, "#!.\0\0erl");
 149
 150 # $outfile should have grown now
 151 if ($reopen) {  # must close file to update EOF marker for stat
 152   close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
 153 }
 154 is(-s $outfile, 4);
 155
 156 # with negative offset and a bit too much length
 157 is(syswrite(O, $a, 5, -3), 3);
 158
 159 # $a still intact
 160 is($a, "#!.\0\0erl");
 161
 162 # $outfile should have grown now
 163 if ($reopen) {  # must close file to update EOF marker for stat
 164   close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
 165 }
 166 is(-s $outfile, 7);
 167
 168 # with implicit length argument
 169 is(syswrite(O, $x), 3);
 170
 171 # $a still intact
 172 is($x, "abc");
 173
 174 # $outfile should have grown now
 175 if ($reopen) {  # must close file to update EOF marker for stat
 176   close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
 177 }
 178 is(-s $outfile, 10);
 179
 180 close(O);
 181
 182 open(I, $outfile) || die "sysio.t: cannot read $outfile: $!";
 183
 184 $b = 'xyz';
 185
 186 # reading too much only return as much as available
 187 is(sysread(I, $b, 100), 10);
 188
 189 # this we should have
 190 is($b, '#!ererlabc');
 191
 192 # test sysseek
 193
 194 is(sysseek(I, 2, 0), 2);
 195 sysread(I, $b, 3);
 196 is($b, 'ere');
 197
 198 is(sysseek(I, -2, 1), 3);
 199 sysread(I, $b, 4);
 200 is($b, 'rerl');
 201
 202 ok(sysseek(I, 0, 0) eq '0 but true');
 203
 204 ok(not defined sysseek(I, -1, 1));
 205
 206 close(I);
 207
 208 unlink $outfile;
 209
 210 # Check that utf8 IO doesn't upgrade the scalar
 211 open(I, ">$outfile") || die "sysio.t: cannot write $outfile: $!";
 212 # Will skip harmlessly on stdioperl
 213 eval {binmode STDOUT, ":utf8"};
 214 die $@ if $@ and $@ !~ /^IO layers \(like ':utf8'\) unavailable/;
 215
 216 # y diaresis is \w when UTF8
 217 $a = chr 255;
 218
 219 unlike($a, qr/\w/);
 220
 221 syswrite I, $a;
 222
 223 # Should not be upgraded as a side effect of syswrite.
 224 unlike($a, qr/\w/);
 225
 226 # This should work
 227 eval {syswrite I, 2;};
 228 is($@, '');
 229
 230 close(I);
 231 unlink $outfile;
 232
 233 chdir('..');
 234
 235 1;
 236
 237 # eof