Filename | /usr/lib64/perl5/vendor_perl/5.16.0/IO/Scalar.pm |
Statements | Executed 19 statements in 10.8ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 84µs | 339µs | BEGIN@149 | IO::Scalar::
1 | 1 | 1 | 73µs | 73µs | BEGIN@154 | IO::Scalar::
1 | 1 | 1 | 72µs | 182µs | BEGIN@152 | IO::Scalar::
1 | 1 | 1 | 63µs | 236µs | BEGIN@157 | IO::Scalar::
1 | 1 | 1 | 55µs | 180µs | BEGIN@158 | IO::Scalar::
1 | 1 | 1 | 49µs | 136µs | BEGIN@150 | IO::Scalar::
1 | 1 | 1 | 47µs | 286µs | BEGIN@151 | IO::Scalar::
0 | 0 | 0 | 0s | 0s | CLOSE | IO::Scalar::
0 | 0 | 0 | 0s | 0s | DESTROY | IO::Scalar::
0 | 0 | 0 | 0s | 0s | EOF | IO::Scalar::
0 | 0 | 0 | 0s | 0s | GETC | IO::Scalar::
0 | 0 | 0 | 0s | 0s | |
0 | 0 | 0 | 0s | 0s | PRINTF | IO::Scalar::
0 | 0 | 0 | 0s | 0s | READ | IO::Scalar::
0 | 0 | 0 | 0s | 0s | READLINE | IO::Scalar::
0 | 0 | 0 | 0s | 0s | SEEK | IO::Scalar::
0 | 0 | 0 | 0s | 0s | TELL | IO::Scalar::
0 | 0 | 0 | 0s | 0s | TIEHANDLE | IO::Scalar::
0 | 0 | 0 | 0s | 0s | WRITE | IO::Scalar::
0 | 0 | 0 | 0s | 0s | __ANON__[:157] | IO::Scalar::
0 | 0 | 0 | 0s | 0s | __ANON__[:158] | IO::Scalar::
0 | 0 | 0 | 0s | 0s | _old_print | IO::Scalar::
0 | 0 | 0 | 0s | 0s | _unsafe_print | IO::Scalar::
0 | 0 | 0 | 0s | 0s | autoflush | IO::Scalar::
0 | 0 | 0 | 0s | 0s | binmode | IO::Scalar::
0 | 0 | 0 | 0s | 0s | clearerr | IO::Scalar::
0 | 0 | 0 | 0s | 0s | close | IO::Scalar::
0 | 0 | 0 | 0s | 0s | eof | IO::Scalar::
0 | 0 | 0 | 0s | 0s | flush | IO::Scalar::
0 | 0 | 0 | 0s | 0s | getc | IO::Scalar::
0 | 0 | 0 | 0s | 0s | getline | IO::Scalar::
0 | 0 | 0 | 0s | 0s | getlines | IO::Scalar::
0 | 0 | 0 | 0s | 0s | new | IO::Scalar::
0 | 0 | 0 | 0s | 0s | open | IO::Scalar::
0 | 0 | 0 | 0s | 0s | opened | IO::Scalar::
0 | 0 | 0 | 0s | 0s | |
0 | 0 | 0 | 0s | 0s | read | IO::Scalar::
0 | 0 | 0 | 0s | 0s | seek | IO::Scalar::
0 | 0 | 0 | 0s | 0s | setpos | IO::Scalar::
0 | 0 | 0 | 0s | 0s | sref | IO::Scalar::
0 | 0 | 0 | 0s | 0s | sysread | IO::Scalar::
0 | 0 | 0 | 0s | 0s | sysseek | IO::Scalar::
0 | 0 | 0 | 0s | 0s | syswrite | IO::Scalar::
0 | 0 | 0 | 0s | 0s | tell | IO::Scalar::
0 | 0 | 0 | 0s | 0s | use_RS | IO::Scalar::
0 | 0 | 0 | 0s | 0s | write | IO::Scalar::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | package IO::Scalar; | ||||
2 | |||||
3 | |||||
4 | =head1 NAME | ||||
5 | |||||
6 | IO::Scalar - IO:: interface for reading/writing a scalar | ||||
7 | |||||
8 | |||||
9 | =head1 SYNOPSIS | ||||
10 | |||||
11 | Perform I/O on strings, using the basic OO interface... | ||||
12 | |||||
13 | use 5.005; | ||||
14 | use IO::Scalar; | ||||
15 | $data = "My message:\n"; | ||||
16 | |||||
17 | ### Open a handle on a string, and append to it: | ||||
18 | $SH = new IO::Scalar \$data; | ||||
19 | $SH->print("Hello"); | ||||
20 | $SH->print(", world!\nBye now!\n"); | ||||
21 | print "The string is now: ", $data, "\n"; | ||||
22 | |||||
23 | ### Open a handle on a string, read it line-by-line, then close it: | ||||
24 | $SH = new IO::Scalar \$data; | ||||
25 | while (defined($_ = $SH->getline)) { | ||||
26 | print "Got line: $_"; | ||||
27 | } | ||||
28 | $SH->close; | ||||
29 | |||||
30 | ### Open a handle on a string, and slurp in all the lines: | ||||
31 | $SH = new IO::Scalar \$data; | ||||
32 | print "All lines:\n", $SH->getlines; | ||||
33 | |||||
34 | ### Get the current position (either of two ways): | ||||
35 | $pos = $SH->getpos; | ||||
36 | $offset = $SH->tell; | ||||
37 | |||||
38 | ### Set the current position (either of two ways): | ||||
39 | $SH->setpos($pos); | ||||
40 | $SH->seek($offset, 0); | ||||
41 | |||||
42 | ### Open an anonymous temporary scalar: | ||||
43 | $SH = new IO::Scalar; | ||||
44 | $SH->print("Hi there!"); | ||||
45 | print "I printed: ", ${$SH->sref}, "\n"; ### get at value | ||||
46 | |||||
47 | |||||
48 | Don't like OO for your I/O? No problem. | ||||
49 | Thanks to the magic of an invisible tie(), the following now | ||||
50 | works out of the box, just as it does with IO::Handle: | ||||
51 | |||||
52 | use 5.005; | ||||
53 | use IO::Scalar; | ||||
54 | $data = "My message:\n"; | ||||
55 | |||||
56 | ### Open a handle on a string, and append to it: | ||||
57 | $SH = new IO::Scalar \$data; | ||||
58 | print $SH "Hello"; | ||||
59 | print $SH ", world!\nBye now!\n"; | ||||
60 | print "The string is now: ", $data, "\n"; | ||||
61 | |||||
62 | ### Open a handle on a string, read it line-by-line, then close it: | ||||
63 | $SH = new IO::Scalar \$data; | ||||
64 | while (<$SH>) { | ||||
65 | print "Got line: $_"; | ||||
66 | } | ||||
67 | close $SH; | ||||
68 | |||||
69 | ### Open a handle on a string, and slurp in all the lines: | ||||
70 | $SH = new IO::Scalar \$data; | ||||
71 | print "All lines:\n", <$SH>; | ||||
72 | |||||
73 | ### Get the current position (WARNING: requires 5.6): | ||||
74 | $offset = tell $SH; | ||||
75 | |||||
76 | ### Set the current position (WARNING: requires 5.6): | ||||
77 | seek $SH, $offset, 0; | ||||
78 | |||||
79 | ### Open an anonymous temporary scalar: | ||||
80 | $SH = new IO::Scalar; | ||||
81 | print $SH "Hi there!"; | ||||
82 | print "I printed: ", ${$SH->sref}, "\n"; ### get at value | ||||
83 | |||||
84 | |||||
85 | And for you folks with 1.x code out there: the old tie() style still works, | ||||
86 | though this is I<unnecessary and deprecated>: | ||||
87 | |||||
88 | use IO::Scalar; | ||||
89 | |||||
90 | ### Writing to a scalar... | ||||
91 | my $s; | ||||
92 | tie *OUT, 'IO::Scalar', \$s; | ||||
93 | print OUT "line 1\nline 2\n", "line 3\n"; | ||||
94 | print "String is now: $s\n" | ||||
95 | |||||
96 | ### Reading and writing an anonymous scalar... | ||||
97 | tie *OUT, 'IO::Scalar'; | ||||
98 | print OUT "line 1\nline 2\n", "line 3\n"; | ||||
99 | tied(OUT)->seek(0,0); | ||||
100 | while (<OUT>) { | ||||
101 | print "Got line: ", $_; | ||||
102 | } | ||||
103 | |||||
104 | |||||
105 | Stringification works, too! | ||||
106 | |||||
107 | my $SH = new IO::Scalar \$data; | ||||
108 | print $SH "Hello, "; | ||||
109 | print $SH "world!"; | ||||
110 | print "I printed: $SH\n"; | ||||
111 | |||||
- - | |||||
114 | =head1 DESCRIPTION | ||||
115 | |||||
116 | This class is part of the IO::Stringy distribution; | ||||
117 | see L<IO::Stringy> for change log and general information. | ||||
118 | |||||
119 | The IO::Scalar class implements objects which behave just like | ||||
120 | IO::Handle (or FileHandle) objects, except that you may use them | ||||
121 | to write to (or read from) scalars. These handles are | ||||
122 | automatically tiehandle'd (though please see L<"WARNINGS"> | ||||
123 | for information relevant to your Perl version). | ||||
124 | |||||
125 | |||||
126 | Basically, this: | ||||
127 | |||||
128 | my $s; | ||||
129 | $SH = new IO::Scalar \$s; | ||||
130 | $SH->print("Hel", "lo, "); ### OO style | ||||
131 | $SH->print("world!\n"); ### ditto | ||||
132 | |||||
133 | Or this: | ||||
134 | |||||
135 | my $s; | ||||
136 | $SH = tie *OUT, 'IO::Scalar', \$s; | ||||
137 | print OUT "Hel", "lo, "; ### non-OO style | ||||
138 | print OUT "world!\n"; ### ditto | ||||
139 | |||||
140 | Causes $s to be set to: | ||||
141 | |||||
142 | "Hello, world!\n" | ||||
143 | |||||
144 | |||||
145 | =head1 PUBLIC INTERFACE | ||||
146 | |||||
147 | =cut | ||||
148 | |||||
149 | 2 | 161µs | 2 | 594µs | # spent 339µs (84+255) within IO::Scalar::BEGIN@149 which was called:
# once (84µs+255µs) by RTP::Webmerge::Process::CSS::Inlinedata::BEGIN@26 at line 149 # spent 339µs making 1 call to IO::Scalar::BEGIN@149
# spent 255µs making 1 call to Exporter::import |
150 | 2 | 172µs | 2 | 222µs | # spent 136µs (49+87) within IO::Scalar::BEGIN@150 which was called:
# once (49µs+87µs) by RTP::Webmerge::Process::CSS::Inlinedata::BEGIN@26 at line 150 # spent 136µs making 1 call to IO::Scalar::BEGIN@150
# spent 87µs making 1 call to strict::import |
151 | 2 | 231µs | 2 | 525µs | # spent 286µs (47+239) within IO::Scalar::BEGIN@151 which was called:
# once (47µs+239µs) by RTP::Webmerge::Process::CSS::Inlinedata::BEGIN@26 at line 151 # spent 286µs making 1 call to IO::Scalar::BEGIN@151
# spent 239µs making 1 call to vars::import |
152 | 2 | 187µs | 2 | 293µs | # spent 182µs (72+110) within IO::Scalar::BEGIN@152 which was called:
# once (72µs+110µs) by RTP::Webmerge::Process::CSS::Inlinedata::BEGIN@26 at line 152 # spent 182µs making 1 call to IO::Scalar::BEGIN@152
# spent 110µs making 1 call to Exporter::import |
153 | |||||
154 | 2 | 448µs | 1 | 73µs | # spent 73µs within IO::Scalar::BEGIN@154 which was called:
# once (73µs+0s) by RTP::Webmerge::Process::CSS::Inlinedata::BEGIN@26 at line 154 # spent 73µs making 1 call to IO::Scalar::BEGIN@154 |
155 | |||||
156 | ### Stringification, courtesy of B. K. Oxley (binkley): :-) | ||||
157 | 2 | 251µs | 2 | 410µs | # spent 236µs (63+173) within IO::Scalar::BEGIN@157 which was called:
# once (63µs+173µs) by RTP::Webmerge::Process::CSS::Inlinedata::BEGIN@26 at line 157 # spent 236µs making 1 call to IO::Scalar::BEGIN@157
# spent 173µs making 1 call to overload::import |
158 | 2 | 8.76ms | 2 | 306µs | # spent 180µs (55+125) within IO::Scalar::BEGIN@158 which was called:
# once (55µs+125µs) by RTP::Webmerge::Process::CSS::Inlinedata::BEGIN@26 at line 158 # spent 180µs making 1 call to IO::Scalar::BEGIN@158
# spent 125µs making 1 call to overload::import |
159 | |||||
160 | ### The package version, both in 1.23 style *and* usable by MakeMaker: | ||||
161 | 1 | 4µs | $VERSION = "2.110"; | ||
162 | |||||
163 | ### Inheritance: | ||||
164 | 1 | 36µs | @ISA = qw(IO::Handle); | ||
165 | |||||
166 | ### This stuff should be got rid of ASAP. | ||||
167 | 1 | 551µs | require IO::WrapTie and push @ISA, 'IO::WrapTie::Slave' if ($] >= 5.004); | ||
168 | |||||
169 | #============================== | ||||
170 | |||||
171 | =head2 Construction | ||||
172 | |||||
173 | =over 4 | ||||
174 | |||||
175 | =cut | ||||
176 | |||||
177 | #------------------------------ | ||||
178 | |||||
179 | =item new [ARGS...] | ||||
180 | |||||
181 | I<Class method.> | ||||
182 | Return a new, unattached scalar handle. | ||||
183 | If any arguments are given, they're sent to open(). | ||||
184 | |||||
185 | =cut | ||||
186 | |||||
187 | sub new { | ||||
188 | my $proto = shift; | ||||
189 | my $class = ref($proto) || $proto; | ||||
190 | my $self = bless \do { local *FH }, $class; | ||||
191 | tie *$self, $class, $self; | ||||
192 | $self->open(@_); ### open on anonymous by default | ||||
193 | $self; | ||||
194 | } | ||||
195 | sub DESTROY { | ||||
196 | shift->close; | ||||
197 | } | ||||
198 | |||||
199 | #------------------------------ | ||||
200 | |||||
201 | =item open [SCALARREF] | ||||
202 | |||||
203 | I<Instance method.> | ||||
204 | Open the scalar handle on a new scalar, pointed to by SCALARREF. | ||||
205 | If no SCALARREF is given, a "private" scalar is created to hold | ||||
206 | the file data. | ||||
207 | |||||
208 | Returns the self object on success, undefined on error. | ||||
209 | |||||
210 | =cut | ||||
211 | |||||
212 | sub open { | ||||
213 | my ($self, $sref) = @_; | ||||
214 | |||||
215 | ### Sanity: | ||||
216 | defined($sref) or do {my $s = ''; $sref = \$s}; | ||||
217 | (ref($sref) eq "SCALAR") or croak "open() needs a ref to a scalar"; | ||||
218 | |||||
219 | ### Setup: | ||||
220 | *$self->{Pos} = 0; ### seek position | ||||
221 | *$self->{SR} = $sref; ### scalar reference | ||||
222 | $self; | ||||
223 | } | ||||
224 | |||||
225 | #------------------------------ | ||||
226 | |||||
227 | =item opened | ||||
228 | |||||
229 | I<Instance method.> | ||||
230 | Is the scalar handle opened on something? | ||||
231 | |||||
232 | =cut | ||||
233 | |||||
234 | sub opened { | ||||
235 | *{shift()}->{SR}; | ||||
236 | } | ||||
237 | |||||
238 | #------------------------------ | ||||
239 | |||||
240 | =item close | ||||
241 | |||||
242 | I<Instance method.> | ||||
243 | Disassociate the scalar handle from its underlying scalar. | ||||
244 | Done automatically on destroy. | ||||
245 | |||||
246 | =cut | ||||
247 | |||||
248 | sub close { | ||||
249 | my $self = shift; | ||||
250 | %{*$self} = (); | ||||
251 | 1; | ||||
252 | } | ||||
253 | |||||
254 | =back | ||||
255 | |||||
256 | =cut | ||||
257 | |||||
- - | |||||
260 | #============================== | ||||
261 | |||||
262 | =head2 Input and output | ||||
263 | |||||
264 | =over 4 | ||||
265 | |||||
266 | =cut | ||||
267 | |||||
268 | |||||
269 | #------------------------------ | ||||
270 | |||||
271 | =item flush | ||||
272 | |||||
273 | I<Instance method.> | ||||
274 | No-op, provided for OO compatibility. | ||||
275 | |||||
276 | =cut | ||||
277 | |||||
278 | sub flush { "0 but true" } | ||||
279 | |||||
280 | #------------------------------ | ||||
281 | |||||
282 | =item getc | ||||
283 | |||||
284 | I<Instance method.> | ||||
285 | Return the next character, or undef if none remain. | ||||
286 | |||||
287 | =cut | ||||
288 | |||||
289 | sub getc { | ||||
290 | my $self = shift; | ||||
291 | |||||
292 | ### Return undef right away if at EOF; else, move pos forward: | ||||
293 | return undef if $self->eof; | ||||
294 | substr(${*$self->{SR}}, *$self->{Pos}++, 1); | ||||
295 | } | ||||
296 | |||||
297 | #------------------------------ | ||||
298 | |||||
299 | =item getline | ||||
300 | |||||
301 | I<Instance method.> | ||||
302 | Return the next line, or undef on end of string. | ||||
303 | Can safely be called in an array context. | ||||
304 | Currently, lines are delimited by "\n". | ||||
305 | |||||
306 | =cut | ||||
307 | |||||
308 | sub getline { | ||||
309 | my $self = shift; | ||||
310 | |||||
311 | ### Return undef right away if at EOF: | ||||
312 | return undef if $self->eof; | ||||
313 | |||||
314 | ### Get next line: | ||||
315 | my $sr = *$self->{SR}; | ||||
316 | my $i = *$self->{Pos}; ### Start matching at this point. | ||||
317 | |||||
318 | ### Minimal impact implementation! | ||||
319 | ### We do the fast fast thing (no regexps) if using the | ||||
320 | ### classic input record separator. | ||||
321 | |||||
322 | ### Case 1: $/ is undef: slurp all... | ||||
323 | if (!defined($/)) { | ||||
324 | *$self->{Pos} = length $$sr; | ||||
325 | return substr($$sr, $i); | ||||
326 | } | ||||
327 | |||||
328 | ### Case 2: $/ is "\n": zoom zoom zoom... | ||||
329 | elsif ($/ eq "\012") { | ||||
330 | |||||
331 | ### Seek ahead for "\n"... yes, this really is faster than regexps. | ||||
332 | my $len = length($$sr); | ||||
333 | for (; $i < $len; ++$i) { | ||||
334 | last if ord (substr ($$sr, $i, 1)) == 10; | ||||
335 | } | ||||
336 | |||||
337 | ### Extract the line: | ||||
338 | my $line; | ||||
339 | if ($i < $len) { ### We found a "\n": | ||||
340 | $line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos} + 1); | ||||
341 | *$self->{Pos} = $i+1; ### Remember where we finished up. | ||||
342 | } | ||||
343 | else { ### No "\n"; slurp the remainder: | ||||
344 | $line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos}); | ||||
345 | *$self->{Pos} = $len; | ||||
346 | } | ||||
347 | return $line; | ||||
348 | } | ||||
349 | |||||
350 | ### Case 3: $/ is ref to int. Do fixed-size records. | ||||
351 | ### (Thanks to Dominique Quatravaux.) | ||||
352 | elsif (ref($/)) { | ||||
353 | my $len = length($$sr); | ||||
354 | my $i = ${$/} + 0; | ||||
355 | my $line = substr ($$sr, *$self->{Pos}, $i); | ||||
356 | *$self->{Pos} += $i; | ||||
357 | *$self->{Pos} = $len if (*$self->{Pos} > $len); | ||||
358 | return $line; | ||||
359 | } | ||||
360 | |||||
361 | ### Case 4: $/ is either "" (paragraphs) or something weird... | ||||
362 | ### This is Graham's general-purpose stuff, which might be | ||||
363 | ### a tad slower than Case 2 for typical data, because | ||||
364 | ### of the regexps. | ||||
365 | else { | ||||
366 | pos($$sr) = $i; | ||||
367 | |||||
368 | ### If in paragraph mode, skip leading lines (and update i!): | ||||
369 | length($/) or | ||||
370 | (($$sr =~ m/\G\n*/g) and ($i = pos($$sr))); | ||||
371 | |||||
372 | ### If we see the separator in the buffer ahead... | ||||
373 | if (length($/) | ||||
374 | ? $$sr =~ m,\Q$/\E,g ### (ordinary sep) TBD: precomp! | ||||
375 | : $$sr =~ m,\n\n,g ### (a paragraph) | ||||
376 | ) { | ||||
377 | *$self->{Pos} = pos $$sr; | ||||
378 | return substr($$sr, $i, *$self->{Pos}-$i); | ||||
379 | } | ||||
380 | ### Else if no separator remains, just slurp the rest: | ||||
381 | else { | ||||
382 | *$self->{Pos} = length $$sr; | ||||
383 | return substr($$sr, $i); | ||||
384 | } | ||||
385 | } | ||||
386 | } | ||||
387 | |||||
388 | #------------------------------ | ||||
389 | |||||
390 | =item getlines | ||||
391 | |||||
392 | I<Instance method.> | ||||
393 | Get all remaining lines. | ||||
394 | It will croak() if accidentally called in a scalar context. | ||||
395 | |||||
396 | =cut | ||||
397 | |||||
398 | sub getlines { | ||||
399 | my $self = shift; | ||||
400 | wantarray or croak("can't call getlines in scalar context!"); | ||||
401 | my ($line, @lines); | ||||
402 | push @lines, $line while (defined($line = $self->getline)); | ||||
403 | @lines; | ||||
404 | } | ||||
405 | |||||
406 | #------------------------------ | ||||
407 | |||||
408 | =item print ARGS... | ||||
409 | |||||
410 | I<Instance method.> | ||||
411 | Print ARGS to the underlying scalar. | ||||
412 | |||||
413 | B<Warning:> this continues to always cause a seek to the end | ||||
414 | of the string, but if you perform seek()s and tell()s, it is | ||||
415 | still safer to explicitly seek-to-end before subsequent print()s. | ||||
416 | |||||
417 | =cut | ||||
418 | |||||
419 | sub print { | ||||
420 | my $self = shift; | ||||
421 | *$self->{Pos} = length(${*$self->{SR}} .= join('', @_) . (defined($\) ? $\ : "")); | ||||
422 | 1; | ||||
423 | } | ||||
424 | sub _unsafe_print { | ||||
425 | my $self = shift; | ||||
426 | my $append = join('', @_) . $\; | ||||
427 | ${*$self->{SR}} .= $append; | ||||
428 | *$self->{Pos} += length($append); | ||||
429 | 1; | ||||
430 | } | ||||
431 | sub _old_print { | ||||
432 | my $self = shift; | ||||
433 | ${*$self->{SR}} .= join('', @_) . $\; | ||||
434 | *$self->{Pos} = length(${*$self->{SR}}); | ||||
435 | 1; | ||||
436 | } | ||||
437 | |||||
438 | |||||
439 | #------------------------------ | ||||
440 | |||||
441 | =item read BUF, NBYTES, [OFFSET] | ||||
442 | |||||
443 | I<Instance method.> | ||||
444 | Read some bytes from the scalar. | ||||
445 | Returns the number of bytes actually read, 0 on end-of-file, undef on error. | ||||
446 | |||||
447 | =cut | ||||
448 | |||||
449 | sub read { | ||||
450 | my $self = $_[0]; | ||||
451 | my $n = $_[2]; | ||||
452 | my $off = $_[3] || 0; | ||||
453 | |||||
454 | my $read = substr(${*$self->{SR}}, *$self->{Pos}, $n); | ||||
455 | $n = length($read); | ||||
456 | *$self->{Pos} += $n; | ||||
457 | ($off ? substr($_[1], $off) : $_[1]) = $read; | ||||
458 | return $n; | ||||
459 | } | ||||
460 | |||||
461 | #------------------------------ | ||||
462 | |||||
463 | =item write BUF, NBYTES, [OFFSET] | ||||
464 | |||||
465 | I<Instance method.> | ||||
466 | Write some bytes to the scalar. | ||||
467 | |||||
468 | =cut | ||||
469 | |||||
470 | sub write { | ||||
471 | my $self = $_[0]; | ||||
472 | my $n = $_[2]; | ||||
473 | my $off = $_[3] || 0; | ||||
474 | |||||
475 | my $data = substr($_[1], $off, $n); | ||||
476 | $n = length($data); | ||||
477 | $self->print($data); | ||||
478 | return $n; | ||||
479 | } | ||||
480 | |||||
481 | #------------------------------ | ||||
482 | |||||
483 | =item sysread BUF, LEN, [OFFSET] | ||||
484 | |||||
485 | I<Instance method.> | ||||
486 | Read some bytes from the scalar. | ||||
487 | Returns the number of bytes actually read, 0 on end-of-file, undef on error. | ||||
488 | |||||
489 | =cut | ||||
490 | |||||
491 | sub sysread { | ||||
492 | my $self = shift; | ||||
493 | $self->read(@_); | ||||
494 | } | ||||
495 | |||||
496 | #------------------------------ | ||||
497 | |||||
498 | =item syswrite BUF, NBYTES, [OFFSET] | ||||
499 | |||||
500 | I<Instance method.> | ||||
501 | Write some bytes to the scalar. | ||||
502 | |||||
503 | =cut | ||||
504 | |||||
505 | sub syswrite { | ||||
506 | my $self = shift; | ||||
507 | $self->write(@_); | ||||
508 | } | ||||
509 | |||||
510 | =back | ||||
511 | |||||
512 | =cut | ||||
513 | |||||
514 | |||||
515 | #============================== | ||||
516 | |||||
517 | =head2 Seeking/telling and other attributes | ||||
518 | |||||
519 | =over 4 | ||||
520 | |||||
521 | =cut | ||||
522 | |||||
523 | |||||
524 | #------------------------------ | ||||
525 | |||||
526 | =item autoflush | ||||
527 | |||||
528 | I<Instance method.> | ||||
529 | No-op, provided for OO compatibility. | ||||
530 | |||||
531 | =cut | ||||
532 | |||||
533 | sub autoflush {} | ||||
534 | |||||
535 | #------------------------------ | ||||
536 | |||||
537 | =item binmode | ||||
538 | |||||
539 | I<Instance method.> | ||||
540 | No-op, provided for OO compatibility. | ||||
541 | |||||
542 | =cut | ||||
543 | |||||
544 | sub binmode {} | ||||
545 | |||||
546 | #------------------------------ | ||||
547 | |||||
548 | =item clearerr | ||||
549 | |||||
550 | I<Instance method.> Clear the error and EOF flags. A no-op. | ||||
551 | |||||
552 | =cut | ||||
553 | |||||
554 | sub clearerr { 1 } | ||||
555 | |||||
556 | #------------------------------ | ||||
557 | |||||
558 | =item eof | ||||
559 | |||||
560 | I<Instance method.> Are we at end of file? | ||||
561 | |||||
562 | =cut | ||||
563 | |||||
564 | sub eof { | ||||
565 | my $self = shift; | ||||
566 | (*$self->{Pos} >= length(${*$self->{SR}})); | ||||
567 | } | ||||
568 | |||||
569 | #------------------------------ | ||||
570 | |||||
571 | =item seek OFFSET, WHENCE | ||||
572 | |||||
573 | I<Instance method.> Seek to a given position in the stream. | ||||
574 | |||||
575 | =cut | ||||
576 | |||||
577 | sub seek { | ||||
578 | my ($self, $pos, $whence) = @_; | ||||
579 | my $eofpos = length(${*$self->{SR}}); | ||||
580 | |||||
581 | ### Seek: | ||||
582 | if ($whence == 0) { *$self->{Pos} = $pos } ### SEEK_SET | ||||
583 | elsif ($whence == 1) { *$self->{Pos} += $pos } ### SEEK_CUR | ||||
584 | elsif ($whence == 2) { *$self->{Pos} = $eofpos + $pos} ### SEEK_END | ||||
585 | else { croak "bad seek whence ($whence)" } | ||||
586 | |||||
587 | ### Fixup: | ||||
588 | if (*$self->{Pos} < 0) { *$self->{Pos} = 0 } | ||||
589 | if (*$self->{Pos} > $eofpos) { *$self->{Pos} = $eofpos } | ||||
590 | return 1; | ||||
591 | } | ||||
592 | |||||
593 | #------------------------------ | ||||
594 | |||||
595 | =item sysseek OFFSET, WHENCE | ||||
596 | |||||
597 | I<Instance method.> Identical to C<seek OFFSET, WHENCE>, I<q.v.> | ||||
598 | |||||
599 | =cut | ||||
600 | |||||
601 | sub sysseek { | ||||
602 | my $self = shift; | ||||
603 | $self->seek (@_); | ||||
604 | } | ||||
605 | |||||
606 | #------------------------------ | ||||
607 | |||||
608 | =item tell | ||||
609 | |||||
610 | I<Instance method.> | ||||
611 | Return the current position in the stream, as a numeric offset. | ||||
612 | |||||
613 | =cut | ||||
614 | |||||
615 | sub tell { *{shift()}->{Pos} } | ||||
616 | |||||
617 | #------------------------------ | ||||
618 | # | ||||
619 | # use_RS [YESNO] | ||||
620 | # | ||||
621 | # I<Instance method.> | ||||
622 | # Obey the curent setting of $/, like IO::Handle does? | ||||
623 | # Default is false in 1.x, but cold-welded true in 2.x and later. | ||||
624 | # | ||||
625 | sub use_RS { | ||||
626 | my ($self, $yesno) = @_; | ||||
627 | carp "use_RS is deprecated and ignored; \$/ is always consulted\n"; | ||||
628 | } | ||||
629 | |||||
630 | #------------------------------ | ||||
631 | |||||
632 | =item setpos POS | ||||
633 | |||||
634 | I<Instance method.> | ||||
635 | Set the current position, using the opaque value returned by C<getpos()>. | ||||
636 | |||||
637 | =cut | ||||
638 | |||||
639 | sub setpos { shift->seek($_[0],0) } | ||||
640 | |||||
641 | #------------------------------ | ||||
642 | |||||
643 | =item getpos | ||||
644 | |||||
645 | I<Instance method.> | ||||
646 | Return the current position in the string, as an opaque object. | ||||
647 | |||||
648 | =cut | ||||
649 | |||||
650 | 1 | 9µs | *getpos = \&tell; | ||
651 | |||||
652 | |||||
653 | #------------------------------ | ||||
654 | |||||
655 | =item sref | ||||
656 | |||||
657 | I<Instance method.> | ||||
658 | Return a reference to the underlying scalar. | ||||
659 | |||||
660 | =cut | ||||
661 | |||||
662 | sub sref { *{shift()}->{SR} } | ||||
663 | |||||
664 | |||||
665 | #------------------------------ | ||||
666 | # Tied handle methods... | ||||
667 | #------------------------------ | ||||
668 | |||||
669 | # Conventional tiehandle interface: | ||||
670 | sub TIEHANDLE { | ||||
671 | ((defined($_[1]) && UNIVERSAL::isa($_[1], "IO::Scalar")) | ||||
672 | ? $_[1] | ||||
673 | : shift->new(@_)); | ||||
674 | } | ||||
675 | sub GETC { shift->getc(@_) } | ||||
676 | sub PRINT { shift->print(@_) } | ||||
677 | sub PRINTF { shift->print(sprintf(shift, @_)) } | ||||
678 | sub READ { shift->read(@_) } | ||||
679 | sub READLINE { wantarray ? shift->getlines(@_) : shift->getline(@_) } | ||||
680 | sub WRITE { shift->write(@_); } | ||||
681 | sub CLOSE { shift->close(@_); } | ||||
682 | sub SEEK { shift->seek(@_); } | ||||
683 | sub TELL { shift->tell(@_); } | ||||
684 | sub EOF { shift->eof(@_); } | ||||
685 | |||||
686 | #------------------------------------------------------------ | ||||
687 | |||||
688 | 1 | 24µs | 1; | ||
689 | |||||
690 | __END__ |