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, 4) };
  74 like($@, qr/^Offset outside string /);
  75
  76 # $x still intact
  77 is($x, 'abc');
  78
  79 # but it should be ok to write from the end of the buffer
  80 syswrite(O, $x, 0, 3);
  81 syswrite(O, $x, 1, 3);
  82
  83 # $outfile still intact
  84 if ($reopen) {  # must close file to update EOF marker for stat
  85   close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
  86 }
  87 ok(!-s $outfile);
  88
  89 # should not be able to write from before the buffer
  90
  91 eval { syswrite(O, $x, 1, -4) };
  92 like($@, qr/^Offset outside string /);
  93
  94 # $x still intact
  95 is($x, 'abc');
  96
  97 # $outfile still intact
  98 if ($reopen) {  # must close file to update EOF marker for stat
  99   close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
 100 }
 101 ok(!-s $outfile);
 102
 103 # [perl #67912] syswrite prints garbage if called with empty scalar and non-zero offset
 104 eval { my $buf = ''; syswrite(O, $buf, 1, 1) };
 105 like($@, qr/^Offset outside string /);
 106
 107 # $x still intact
 108 is($x, 'abc');
 109
 110 # $outfile still intact
 111 if ($reopen) {  # must close file to update EOF marker for stat
 112   close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
 113 }
 114 ok(!-s $outfile);
 115
 116 eval { my $buf = 'x'; syswrite(O, $buf, 1, 2) };
 117 like($@, qr/^Offset outside string /);
 118
 119 # $x still intact
 120 is($x, 'abc');
 121
 122 # $outfile still intact
 123 if ($reopen) {  # must close file to update EOF marker for stat
 124   close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
 125 }
 126 ok(!-s $outfile);
 127
 128 # default offset 0
 129 if (syswrite(O, $a, 2) == 2){
 130   pass();
 131 } else {
 132   diag($!);
 133   fail();
 134   # most other tests make no sense after e.g. "No space left on device"
 135   die $!;
 136 }
 137
 138
 139 # $a still intact
 140 is($a, "#!.\0\0erl");
 141
 142 # $outfile should have grown now
 143 if ($reopen) {  # must close file to update EOF marker for stat
 144   close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
 145 }
 146 is(-s $outfile, 2);
 147
 148 # with offset
 149 is(syswrite(O, $a, 2, 5), 2);
 150
 151 # $a still intact
 152 is($a, "#!.\0\0erl");
 153
 154 # $outfile should have grown now
 155 if ($reopen) {  # must close file to update EOF marker for stat
 156   close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
 157 }
 158 is(-s $outfile, 4);
 159
 160 # with negative offset and a bit too much length
 161 is(syswrite(O, $a, 5, -3), 3);
 162
 163 # $a still intact
 164 is($a, "#!.\0\0erl");
 165
 166 # $outfile should have grown now
 167 if ($reopen) {  # must close file to update EOF marker for stat
 168   close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
 169 }
 170 is(-s $outfile, 7);
 171
 172 # with implicit length argument
 173 is(syswrite(O, $x), 3);
 174
 175 # $a still intact
 176 is($x, "abc");
 177
 178 # $outfile should have grown now
 179 if ($reopen) {  # must close file to update EOF marker for stat
 180   close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
 181 }
 182 is(-s $outfile, 10);
 183
 184 close(O);
 185
 186 open(I, $outfile) || die "sysio.t: cannot read $outfile: $!";
 187
 188 $b = 'xyz';
 189
 190 # reading too much only return as much as available
 191 is(sysread(I, $b, 100), 10);
 192
 193 # this we should have
 194 is($b, '#!ererlabc');
 195
 196 # test sysseek
 197
 198 is(sysseek(I, 2, 0), 2);
 199 sysread(I, $b, 3);
 200 is($b, 'ere');
 201
 202 is(sysseek(I, -2, 1), 3);
 203 sysread(I, $b, 4);
 204 is($b, 'rerl');
 205
 206 ok(sysseek(I, 0, 0) eq '0 but true');
 207
 208 ok(not defined sysseek(I, -1, 1));
 209
 210 close(I);
 211
 212 unlink $outfile;
 213
 214 # Check that utf8 IO doesn't upgrade the scalar
 215 open(I, ">$outfile") || die "sysio.t: cannot write $outfile: $!";
 216 # Will skip harmlessly on stdioperl
 217 eval {binmode STDOUT, ":utf8"};
 218 die $@ if $@ and $@ !~ /^IO layers \(like ':utf8'\) unavailable/;
 219
 220 # y diaresis is \w when UTF8
 221 $a = chr 255;
 222
 223 unlike($a, qr/\w/);
 224
 225 syswrite I, $a;
 226
 227 # Should not be upgraded as a side effect of syswrite.
 228 unlike($a, qr/\w/);
 229
 230 # This should work
 231 eval {syswrite I, 2;};
 232 is($@, '');
 233
 234 close(I);
 235 unlink $outfile;
 236
 237 chdir('..');
 238
 239 1;
 240
 241 # eof