t/op/sysio.t

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