t/op/sysio.t

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