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