t/op/sysio.t

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