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