Commit | Line | Data |
---|---|---|
bbce6d69 | 1 | #!./perl |
2 | ||
6aa2f6a7 | 3 | print "1..42\n"; |
bbce6d69 | 4 | |
bfb65faf | 5 | chdir('op') || chdir('t/op') || die "sysio.t: cannot look for myself: $!"; |
6aa2f6a7 | 6 | @INC = '../../lib'; |
bbce6d69 | 7 | |
8 | open(I, 'sysio.t') || die "sysio.t: cannot find myself: $!"; | |
9 | ||
502257bb A |
10 | $reopen = ($^O eq 'VMS' || |
11 | $^O eq 'os2' || | |
12 | $^O eq 'MSWin32' || | |
13 | $^O eq 'NetWare' || | |
14 | $^O eq 'dos' || | |
57af3f31 | 15 | $^O eq 'mpeix'); |
9fcfb7d3 | 16 | |
bbce6d69 | 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 | |
9fcfb7d3 CB |
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 | } | |
bbce6d69 | 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 | |
9fcfb7d3 CB |
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 | } | |
bbce6d69 | 112 | print 'not ' if (-s $outfile); |
113 | print "ok 19\n"; | |
114 | ||
115 | # default offset 0 | |
502257bb A |
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 | ||
bbce6d69 | 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 | |
9fcfb7d3 CB |
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 | } | |
bbce6d69 | 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 | |
9fcfb7d3 CB |
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 | } | |
bbce6d69 | 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 | |
9fcfb7d3 CB |
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 | } | |
bbce6d69 | 163 | print 'not ' unless (-s $outfile == 7); |
164 | print "ok 28\n"; | |
165 | ||
b56ec344 JH |
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 | ||
bbce6d69 | 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 | |
b56ec344 JH |
188 | print 'not ' unless (sysread(I, $b, 100) == 10); |
189 | print "ok 32\n"; | |
bbce6d69 | 190 | # this we should have |
b56ec344 JH |
191 | print 'not ' unless ($b eq '#!ererlabc'); |
192 | print "ok 33\n"; | |
bbce6d69 | 193 | |
8903cb82 | 194 | # test sysseek |
137443ea | 195 | |
8903cb82 | 196 | print 'not ' unless sysseek(I, 2, 0) == 2; |
b56ec344 | 197 | print "ok 34\n"; |
137443ea | 198 | sysread(I, $b, 3); |
199 | print 'not ' unless $b eq 'ere'; | |
b56ec344 | 200 | print "ok 35\n"; |
137443ea | 201 | |
8903cb82 | 202 | print 'not ' unless sysseek(I, -2, 1) == 3; |
b56ec344 | 203 | print "ok 36\n"; |
137443ea | 204 | sysread(I, $b, 4); |
205 | print 'not ' unless $b eq 'rerl'; | |
b56ec344 | 206 | print "ok 37\n"; |
137443ea | 207 | |
8903cb82 | 208 | print 'not ' unless sysseek(I, 0, 0) eq '0 but true'; |
b56ec344 | 209 | print "ok 38\n"; |
8903cb82 | 210 | print 'not ' if defined sysseek(I, -1, 1); |
b56ec344 | 211 | print "ok 39\n"; |
8903cb82 | 212 | |
bbce6d69 | 213 | close(I); |
214 | ||
215 | unlink $outfile; | |
216 | ||
6aa2f6a7 NC |
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 | ||
502257bb | 240 | chdir('..'); |
8ebc5c01 | 241 | |
bbce6d69 | 242 | 1; |
243 | ||
244 | # eof |