This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Allow syswrite with offset same as length of string [perl #70095]
[perl5.git] / 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