This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
966a5169971588c38f46fecf4ceb61805bc0157e
[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, 3) };
74 like($@, qr/^Offset outside string /);
75
76 # $x still intact
77 is($x, 'abc');
78
79 # $outfile still intact
80 if ($reopen) {  # must close file to update EOF marker for stat
81   close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
82 }
83 ok(!-s $outfile);
84
85 # should not be able to write from before the buffer
86
87 eval { syswrite(O, $x, 1, -4) };
88 like($@, qr/^Offset outside string /);
89
90 # $x still intact
91 is($x, 'abc');
92
93 # $outfile still intact
94 if ($reopen) {  # must close file to update EOF marker for stat
95   close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
96 }
97 ok(!-s $outfile);
98
99 # [perl #67912] syswrite prints garbage if called with empty scalar and non-zero offset
100 eval { my $buf = ''; syswrite(O, $buf, 1, 0) };
101 like($@, qr/^Offset outside string /);
102
103 # $x still intact
104 is($x, 'abc');
105
106 # $outfile still intact
107 if ($reopen) {  # must close file to update EOF marker for stat
108   close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
109 }
110 ok(!-s $outfile);
111
112 eval { my $buf = 'x'; syswrite(O, $buf, 1, 1) };
113 like($@, qr/^Offset outside string /);
114
115 # $x still intact
116 is($x, 'abc');
117
118 # $outfile still intact
119 if ($reopen) {  # must close file to update EOF marker for stat
120   close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
121 }
122 ok(!-s $outfile);
123
124 # default offset 0
125 if (syswrite(O, $a, 2) == 2){
126   pass();
127 } else {
128   diag($!);
129   fail();
130   # most other tests make no sense after e.g. "No space left on device"
131   die $!;
132 }
133
134
135 # $a still intact
136 is($a, "#!.\0\0erl");
137
138 # $outfile should have grown now
139 if ($reopen) {  # must close file to update EOF marker for stat
140   close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
141 }
142 is(-s $outfile, 2);
143
144 # with offset
145 is(syswrite(O, $a, 2, 5), 2);
146
147 # $a still intact
148 is($a, "#!.\0\0erl");
149
150 # $outfile should have grown now
151 if ($reopen) {  # must close file to update EOF marker for stat
152   close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
153 }
154 is(-s $outfile, 4);
155
156 # with negative offset and a bit too much length
157 is(syswrite(O, $a, 5, -3), 3);
158
159 # $a still intact
160 is($a, "#!.\0\0erl");
161
162 # $outfile should have grown now
163 if ($reopen) {  # must close file to update EOF marker for stat
164   close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!";
165 }
166 is(-s $outfile, 7);
167
168 # with implicit length argument
169 is(syswrite(O, $x), 3);
170
171 # $a still intact
172 is($x, "abc");
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 is(-s $outfile, 10);
179
180 close(O);
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 is(sysread(I, $b, 100), 10);
188
189 # this we should have
190 is($b, '#!ererlabc');
191
192 # test sysseek
193
194 is(sysseek(I, 2, 0), 2);
195 sysread(I, $b, 3);
196 is($b, 'ere');
197
198 is(sysseek(I, -2, 1), 3);
199 sysread(I, $b, 4);
200 is($b, 'rerl');
201
202 ok(sysseek(I, 0, 0) eq '0 but true');
203
204 ok(not defined sysseek(I, -1, 1));
205
206 close(I);
207
208 unlink $outfile;
209
210 # Check that utf8 IO doesn't upgrade the scalar
211 open(I, ">$outfile") || die "sysio.t: cannot write $outfile: $!";
212 # Will skip harmlessly on stdioperl
213 eval {binmode STDOUT, ":utf8"};
214 die $@ if $@ and $@ !~ /^IO layers \(like ':utf8'\) unavailable/;
215
216 # y diaresis is \w when UTF8
217 $a = chr 255;
218
219 unlike($a, qr/\w/);
220
221 syswrite I, $a;
222
223 # Should not be upgraded as a side effect of syswrite.
224 unlike($a, qr/\w/);
225
226 # This should work
227 eval {syswrite I, 2;};
228 is($@, '');
229
230 close(I);
231 unlink $outfile;
232
233 chdir('..');
234
235 1;
236
237 # eof