Commit | Line | Data |
---|---|---|
afad11a2 RS |
1 | package Test::Builder::IO::Scalar; |
2 | ||
3 | ||
4 | =head1 NAME | |
5 | ||
6 | Test::Builder::IO::Scalar - A copy of IO::Scalar for Test::Builder | |
7 | ||
8 | =head1 DESCRIPTION | |
9 | ||
10 | This is a copy of L<IO::Scalar> which ships with L<Test::Builder> to | |
11 | support scalar references as filehandles on Perl 5.6. Newer | |
12 | versions of Perl simply use C<open()>'s built in support. | |
13 | ||
14 | L<Test::Builder> can not have dependencies on other modules without | |
15 | careful consideration, so its simply been copied into the distribution. | |
16 | ||
17 | =head1 COPYRIGHT and LICENSE | |
18 | ||
19 | This file came from the "IO-stringy" Perl5 toolkit. | |
20 | ||
21 | Copyright (c) 1996 by Eryq. All rights reserved. | |
22 | Copyright (c) 1999,2001 by ZeeGee Software Inc. All rights reserved. | |
23 | ||
24 | This program is free software; you can redistribute it and/or | |
25 | modify it under the same terms as Perl itself. | |
26 | ||
27 | ||
28 | =cut | |
29 | ||
30 | # This is copied code, I don't care. | |
31 | ##no critic | |
32 | ||
33 | use Carp; | |
34 | use strict; | |
35 | use vars qw($VERSION @ISA); | |
36 | use IO::Handle; | |
37 | ||
38 | use 5.005; | |
39 | ||
40 | ### The package version, both in 1.23 style *and* usable by MakeMaker: | |
41 | $VERSION = "2.113"; | |
42 | ||
43 | ### Inheritance: | |
44 | @ISA = qw(IO::Handle); | |
45 | ||
46 | #============================== | |
47 | ||
48 | =head2 Construction | |
49 | ||
50 | =over 4 | |
51 | ||
52 | =cut | |
53 | ||
54 | #------------------------------ | |
55 | ||
56 | =item new [ARGS...] | |
57 | ||
58 | I<Class method.> | |
59 | Return a new, unattached scalar handle. | |
60 | If any arguments are given, they're sent to open(). | |
61 | ||
62 | =cut | |
63 | ||
64 | sub new { | |
65 | my $proto = shift; | |
66 | my $class = ref($proto) || $proto; | |
67 | my $self = bless \do { local *FH }, $class; | |
68 | tie *$self, $class, $self; | |
69 | $self->open(@_); ### open on anonymous by default | |
70 | $self; | |
71 | } | |
72 | sub DESTROY { | |
73 | shift->close; | |
74 | } | |
75 | ||
76 | #------------------------------ | |
77 | ||
78 | =item open [SCALARREF] | |
79 | ||
80 | I<Instance method.> | |
81 | Open the scalar handle on a new scalar, pointed to by SCALARREF. | |
82 | If no SCALARREF is given, a "private" scalar is created to hold | |
83 | the file data. | |
84 | ||
85 | Returns the self object on success, undefined on error. | |
86 | ||
87 | =cut | |
88 | ||
89 | sub open { | |
90 | my ($self, $sref) = @_; | |
91 | ||
92 | ### Sanity: | |
93 | defined($sref) or do {my $s = ''; $sref = \$s}; | |
94 | (ref($sref) eq "SCALAR") or croak "open() needs a ref to a scalar"; | |
95 | ||
96 | ### Setup: | |
97 | *$self->{Pos} = 0; ### seek position | |
98 | *$self->{SR} = $sref; ### scalar reference | |
99 | $self; | |
100 | } | |
101 | ||
102 | #------------------------------ | |
103 | ||
104 | =item opened | |
105 | ||
106 | I<Instance method.> | |
107 | Is the scalar handle opened on something? | |
108 | ||
109 | =cut | |
110 | ||
111 | sub opened { | |
112 | *{shift()}->{SR}; | |
113 | } | |
114 | ||
115 | #------------------------------ | |
116 | ||
117 | =item close | |
118 | ||
119 | I<Instance method.> | |
120 | Disassociate the scalar handle from its underlying scalar. | |
121 | Done automatically on destroy. | |
122 | ||
123 | =cut | |
124 | ||
125 | sub close { | |
126 | my $self = shift; | |
127 | %{*$self} = (); | |
128 | 1; | |
129 | } | |
130 | ||
131 | =back | |
132 | ||
133 | =cut | |
134 | ||
135 | ||
136 | ||
137 | #============================== | |
138 | ||
139 | =head2 Input and output | |
140 | ||
141 | =over 4 | |
142 | ||
143 | =cut | |
144 | ||
145 | ||
146 | #------------------------------ | |
147 | ||
148 | =item flush | |
149 | ||
150 | I<Instance method.> | |
151 | No-op, provided for OO compatibility. | |
152 | ||
153 | =cut | |
154 | ||
155 | sub flush { "0 but true" } | |
156 | ||
157 | #------------------------------ | |
158 | ||
159 | =item getc | |
160 | ||
161 | I<Instance method.> | |
162 | Return the next character, or undef if none remain. | |
163 | ||
164 | =cut | |
165 | ||
166 | sub getc { | |
167 | my $self = shift; | |
168 | ||
169 | ### Return undef right away if at EOF; else, move pos forward: | |
170 | return undef if $self->eof; | |
171 | substr(${*$self->{SR}}, *$self->{Pos}++, 1); | |
172 | } | |
173 | ||
174 | #------------------------------ | |
175 | ||
176 | =item getline | |
177 | ||
178 | I<Instance method.> | |
179 | Return the next line, or undef on end of string. | |
180 | Can safely be called in an array context. | |
181 | Currently, lines are delimited by "\n". | |
182 | ||
183 | =cut | |
184 | ||
185 | sub getline { | |
186 | my $self = shift; | |
187 | ||
188 | ### Return undef right away if at EOF: | |
189 | return undef if $self->eof; | |
190 | ||
191 | ### Get next line: | |
192 | my $sr = *$self->{SR}; | |
193 | my $i = *$self->{Pos}; ### Start matching at this point. | |
194 | ||
195 | ### Minimal impact implementation! | |
196 | ### We do the fast fast thing (no regexps) if using the | |
197 | ### classic input record separator. | |
198 | ||
199 | ### Case 1: $/ is undef: slurp all... | |
200 | if (!defined($/)) { | |
201 | *$self->{Pos} = length $$sr; | |
202 | return substr($$sr, $i); | |
203 | } | |
204 | ||
205 | ### Case 2: $/ is "\n": zoom zoom zoom... | |
206 | elsif ($/ eq "\012") { | |
207 | ||
208 | ### Seek ahead for "\n"... yes, this really is faster than regexps. | |
209 | my $len = length($$sr); | |
210 | for (; $i < $len; ++$i) { | |
211 | last if ord (substr ($$sr, $i, 1)) == 10; | |
212 | } | |
213 | ||
214 | ### Extract the line: | |
215 | my $line; | |
216 | if ($i < $len) { ### We found a "\n": | |
217 | $line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos} + 1); | |
218 | *$self->{Pos} = $i+1; ### Remember where we finished up. | |
219 | } | |
220 | else { ### No "\n"; slurp the remainder: | |
221 | $line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos}); | |
222 | *$self->{Pos} = $len; | |
223 | } | |
224 | return $line; | |
225 | } | |
226 | ||
227 | ### Case 3: $/ is ref to int. Do fixed-size records. | |
228 | ### (Thanks to Dominique Quatravaux.) | |
229 | elsif (ref($/)) { | |
230 | my $len = length($$sr); | |
231 | my $i = ${$/} + 0; | |
232 | my $line = substr ($$sr, *$self->{Pos}, $i); | |
233 | *$self->{Pos} += $i; | |
234 | *$self->{Pos} = $len if (*$self->{Pos} > $len); | |
235 | return $line; | |
236 | } | |
237 | ||
238 | ### Case 4: $/ is either "" (paragraphs) or something weird... | |
239 | ### This is Graham's general-purpose stuff, which might be | |
240 | ### a tad slower than Case 2 for typical data, because | |
241 | ### of the regexps. | |
242 | else { | |
243 | pos($$sr) = $i; | |
244 | ||
245 | ### If in paragraph mode, skip leading lines (and update i!): | |
246 | length($/) or | |
247 | (($$sr =~ m/\G\n*/g) and ($i = pos($$sr))); | |
248 | ||
249 | ### If we see the separator in the buffer ahead... | |
250 | if (length($/) | |
251 | ? $$sr =~ m,\Q$/\E,g ### (ordinary sep) TBD: precomp! | |
252 | : $$sr =~ m,\n\n,g ### (a paragraph) | |
253 | ) { | |
254 | *$self->{Pos} = pos $$sr; | |
255 | return substr($$sr, $i, *$self->{Pos}-$i); | |
256 | } | |
257 | ### Else if no separator remains, just slurp the rest: | |
258 | else { | |
259 | *$self->{Pos} = length $$sr; | |
260 | return substr($$sr, $i); | |
261 | } | |
262 | } | |
263 | } | |
264 | ||
265 | #------------------------------ | |
266 | ||
267 | =item getlines | |
268 | ||
269 | I<Instance method.> | |
270 | Get all remaining lines. | |
271 | It will croak() if accidentally called in a scalar context. | |
272 | ||
273 | =cut | |
274 | ||
275 | sub getlines { | |
276 | my $self = shift; | |
277 | wantarray or croak("can't call getlines in scalar context!"); | |
278 | my ($line, @lines); | |
279 | push @lines, $line while (defined($line = $self->getline)); | |
280 | @lines; | |
281 | } | |
282 | ||
283 | #------------------------------ | |
284 | ||
285 | =item print ARGS... | |
286 | ||
287 | I<Instance method.> | |
288 | Print ARGS to the underlying scalar. | |
289 | ||
290 | B<Warning:> this continues to always cause a seek to the end | |
291 | of the string, but if you perform seek()s and tell()s, it is | |
292 | still safer to explicitly seek-to-end before subsequent print()s. | |
293 | ||
294 | =cut | |
295 | ||
296 | sub print { | |
297 | my $self = shift; | |
298 | *$self->{Pos} = length(${*$self->{SR}} .= join('', @_) . (defined($\) ? $\ : "")); | |
299 | 1; | |
300 | } | |
301 | sub _unsafe_print { | |
302 | my $self = shift; | |
303 | my $append = join('', @_) . $\; | |
304 | ${*$self->{SR}} .= $append; | |
305 | *$self->{Pos} += length($append); | |
306 | 1; | |
307 | } | |
308 | sub _old_print { | |
309 | my $self = shift; | |
310 | ${*$self->{SR}} .= join('', @_) . $\; | |
311 | *$self->{Pos} = length(${*$self->{SR}}); | |
312 | 1; | |
313 | } | |
314 | ||
315 | ||
316 | #------------------------------ | |
317 | ||
318 | =item read BUF, NBYTES, [OFFSET] | |
319 | ||
320 | I<Instance method.> | |
321 | Read some bytes from the scalar. | |
322 | Returns the number of bytes actually read, 0 on end-of-file, undef on error. | |
323 | ||
324 | =cut | |
325 | ||
326 | sub read { | |
327 | my $self = $_[0]; | |
328 | my $n = $_[2]; | |
329 | my $off = $_[3] || 0; | |
330 | ||
331 | my $read = substr(${*$self->{SR}}, *$self->{Pos}, $n); | |
332 | $n = length($read); | |
333 | *$self->{Pos} += $n; | |
334 | ($off ? substr($_[1], $off) : $_[1]) = $read; | |
335 | return $n; | |
336 | } | |
337 | ||
338 | #------------------------------ | |
339 | ||
340 | =item write BUF, NBYTES, [OFFSET] | |
341 | ||
342 | I<Instance method.> | |
343 | Write some bytes to the scalar. | |
344 | ||
345 | =cut | |
346 | ||
347 | sub write { | |
348 | my $self = $_[0]; | |
349 | my $n = $_[2]; | |
350 | my $off = $_[3] || 0; | |
351 | ||
352 | my $data = substr($_[1], $off, $n); | |
353 | $n = length($data); | |
354 | $self->print($data); | |
355 | return $n; | |
356 | } | |
357 | ||
358 | #------------------------------ | |
359 | ||
360 | =item sysread BUF, LEN, [OFFSET] | |
361 | ||
362 | I<Instance method.> | |
363 | Read some bytes from the scalar. | |
364 | Returns the number of bytes actually read, 0 on end-of-file, undef on error. | |
365 | ||
366 | =cut | |
367 | ||
368 | sub sysread { | |
369 | my $self = shift; | |
370 | $self->read(@_); | |
371 | } | |
372 | ||
373 | #------------------------------ | |
374 | ||
375 | =item syswrite BUF, NBYTES, [OFFSET] | |
376 | ||
377 | I<Instance method.> | |
378 | Write some bytes to the scalar. | |
379 | ||
380 | =cut | |
381 | ||
382 | sub syswrite { | |
383 | my $self = shift; | |
384 | $self->write(@_); | |
385 | } | |
386 | ||
387 | =back | |
388 | ||
389 | =cut | |
390 | ||
391 | ||
392 | #============================== | |
393 | ||
394 | =head2 Seeking/telling and other attributes | |
395 | ||
396 | =over 4 | |
397 | ||
398 | =cut | |
399 | ||
400 | ||
401 | #------------------------------ | |
402 | ||
403 | =item autoflush | |
404 | ||
405 | I<Instance method.> | |
406 | No-op, provided for OO compatibility. | |
407 | ||
408 | =cut | |
409 | ||
410 | sub autoflush {} | |
411 | ||
412 | #------------------------------ | |
413 | ||
414 | =item binmode | |
415 | ||
416 | I<Instance method.> | |
417 | No-op, provided for OO compatibility. | |
418 | ||
419 | =cut | |
420 | ||
421 | sub binmode {} | |
422 | ||
423 | #------------------------------ | |
424 | ||
425 | =item clearerr | |
426 | ||
427 | I<Instance method.> Clear the error and EOF flags. A no-op. | |
428 | ||
429 | =cut | |
430 | ||
431 | sub clearerr { 1 } | |
432 | ||
433 | #------------------------------ | |
434 | ||
435 | =item eof | |
436 | ||
437 | I<Instance method.> Are we at end of file? | |
438 | ||
439 | =cut | |
440 | ||
441 | sub eof { | |
442 | my $self = shift; | |
443 | (*$self->{Pos} >= length(${*$self->{SR}})); | |
444 | } | |
445 | ||
446 | #------------------------------ | |
447 | ||
448 | =item seek OFFSET, WHENCE | |
449 | ||
450 | I<Instance method.> Seek to a given position in the stream. | |
451 | ||
452 | =cut | |
453 | ||
454 | sub seek { | |
455 | my ($self, $pos, $whence) = @_; | |
456 | my $eofpos = length(${*$self->{SR}}); | |
457 | ||
458 | ### Seek: | |
459 | if ($whence == 0) { *$self->{Pos} = $pos } ### SEEK_SET | |
460 | elsif ($whence == 1) { *$self->{Pos} += $pos } ### SEEK_CUR | |
461 | elsif ($whence == 2) { *$self->{Pos} = $eofpos + $pos} ### SEEK_END | |
462 | else { croak "bad seek whence ($whence)" } | |
463 | ||
464 | ### Fixup: | |
465 | if (*$self->{Pos} < 0) { *$self->{Pos} = 0 } | |
466 | if (*$self->{Pos} > $eofpos) { *$self->{Pos} = $eofpos } | |
467 | return 1; | |
468 | } | |
469 | ||
470 | #------------------------------ | |
471 | ||
472 | =item sysseek OFFSET, WHENCE | |
473 | ||
474 | I<Instance method.> Identical to C<seek OFFSET, WHENCE>, I<q.v.> | |
475 | ||
476 | =cut | |
477 | ||
478 | sub sysseek { | |
479 | my $self = shift; | |
480 | $self->seek (@_); | |
481 | } | |
482 | ||
483 | #------------------------------ | |
484 | ||
485 | =item tell | |
486 | ||
487 | I<Instance method.> | |
488 | Return the current position in the stream, as a numeric offset. | |
489 | ||
490 | =cut | |
491 | ||
492 | sub tell { *{shift()}->{Pos} } | |
493 | ||
494 | #------------------------------ | |
495 | ||
496 | =item use_RS [YESNO] | |
497 | ||
498 | I<Instance method.> | |
499 | B<Deprecated and ignored.> | |
500 | Obey the current setting of $/, like IO::Handle does? | |
501 | Default is false in 1.x, but cold-welded true in 2.x and later. | |
502 | ||
503 | =cut | |
504 | ||
505 | sub use_RS { | |
506 | my ($self, $yesno) = @_; | |
507 | carp "use_RS is deprecated and ignored; \$/ is always consulted\n"; | |
508 | } | |
509 | ||
510 | #------------------------------ | |
511 | ||
512 | =item setpos POS | |
513 | ||
514 | I<Instance method.> | |
515 | Set the current position, using the opaque value returned by C<getpos()>. | |
516 | ||
517 | =cut | |
518 | ||
519 | sub setpos { shift->seek($_[0],0) } | |
520 | ||
521 | #------------------------------ | |
522 | ||
523 | =item getpos | |
524 | ||
525 | I<Instance method.> | |
526 | Return the current position in the string, as an opaque object. | |
527 | ||
528 | =cut | |
529 | ||
530 | *getpos = \&tell; | |
531 | ||
532 | ||
533 | #------------------------------ | |
534 | ||
535 | =item sref | |
536 | ||
537 | I<Instance method.> | |
538 | Return a reference to the underlying scalar. | |
539 | ||
540 | =cut | |
541 | ||
542 | sub sref { *{shift()}->{SR} } | |
543 | ||
544 | ||
545 | #------------------------------ | |
546 | # Tied handle methods... | |
547 | #------------------------------ | |
548 | ||
549 | # Conventional tiehandle interface: | |
550 | sub TIEHANDLE { | |
551 | ((defined($_[1]) && UNIVERSAL::isa($_[1], __PACKAGE__)) | |
552 | ? $_[1] | |
553 | : shift->new(@_)); | |
554 | } | |
555 | sub GETC { shift->getc(@_) } | |
556 | sub PRINT { shift->print(@_) } | |
557 | sub PRINTF { shift->print(sprintf(shift, @_)) } | |
558 | sub READ { shift->read(@_) } | |
559 | sub READLINE { wantarray ? shift->getlines(@_) : shift->getline(@_) } | |
560 | sub WRITE { shift->write(@_); } | |
561 | sub CLOSE { shift->close(@_); } | |
562 | sub SEEK { shift->seek(@_); } | |
563 | sub TELL { shift->tell(@_); } | |
564 | sub EOF { shift->eof(@_); } | |
1195d90a | 565 | sub FILENO { -1 } |
afad11a2 RS |
566 | |
567 | #------------------------------------------------------------ | |
568 | ||
569 | 1; | |
570 | ||
571 | __END__ | |
572 | ||
573 | ||
574 | ||
575 | =back | |
576 | ||
577 | =cut | |
578 | ||
579 | ||
580 | =head1 WARNINGS | |
581 | ||
582 | Perl's TIEHANDLE spec was incomplete prior to 5.005_57; | |
583 | it was missing support for C<seek()>, C<tell()>, and C<eof()>. | |
584 | Attempting to use these functions with an IO::Scalar will not work | |
585 | prior to 5.005_57. IO::Scalar will not have the relevant methods | |
586 | invoked; and even worse, this kind of bug can lie dormant for a while. | |
587 | If you turn warnings on (via C<$^W> or C<perl -w>), | |
588 | and you see something like this... | |
589 | ||
590 | attempt to seek on unopened filehandle | |
591 | ||
592 | ...then you are probably trying to use one of these functions | |
593 | on an IO::Scalar with an old Perl. The remedy is to simply | |
594 | use the OO version; e.g.: | |
595 | ||
596 | $SH->seek(0,0); ### GOOD: will work on any 5.005 | |
597 | seek($SH,0,0); ### WARNING: will only work on 5.005_57 and beyond | |
598 | ||
599 | ||
600 | =head1 VERSION | |
601 | ||
602 | $Id: Scalar.pm,v 1.6 2005/02/10 21:21:53 dfs Exp $ | |
603 | ||
604 | ||
605 | =head1 AUTHORS | |
606 | ||
607 | =head2 Primary Maintainer | |
608 | ||
609 | David F. Skoll (F<dfs@roaringpenguin.com>). | |
610 | ||
611 | =head2 Principal author | |
612 | ||
613 | Eryq (F<eryq@zeegee.com>). | |
614 | President, ZeeGee Software Inc (F<http://www.zeegee.com>). | |
615 | ||
616 | ||
617 | =head2 Other contributors | |
618 | ||
619 | The full set of contributors always includes the folks mentioned | |
620 | in L<IO::Stringy/"CHANGE LOG">. But just the same, special | |
621 | thanks to the following individuals for their invaluable contributions | |
622 | (if I've forgotten or misspelled your name, please email me!): | |
623 | ||
624 | I<Andy Glew,> | |
625 | for contributing C<getc()>. | |
626 | ||
627 | I<Brandon Browning,> | |
628 | for suggesting C<opened()>. | |
629 | ||
630 | I<David Richter,> | |
631 | for finding and fixing the bug in C<PRINTF()>. | |
632 | ||
633 | I<Eric L. Brine,> | |
634 | for his offset-using read() and write() implementations. | |
635 | ||
636 | I<Richard Jones,> | |
637 | for his patches to massively improve the performance of C<getline()> | |
638 | and add C<sysread> and C<syswrite>. | |
639 | ||
640 | I<B. K. Oxley (binkley),> | |
641 | for stringification and inheritance improvements, | |
642 | and sundry good ideas. | |
643 | ||
644 | I<Doug Wilson,> | |
645 | for the IO::Handle inheritance and automatic tie-ing. | |
646 | ||
647 | ||
648 | =head1 SEE ALSO | |
649 | ||
650 | L<IO::String>, which is quite similar but which was designed | |
651 | more-recently and with an IO::Handle-like interface in mind, | |
652 | so you could mix OO- and native-filehandle usage without using tied(). | |
653 | ||
654 | I<Note:> as of version 2.x, these classes all work like | |
655 | their IO::Handle counterparts, so we have comparable | |
656 | functionality to IO::String. | |
657 | ||
658 | =cut | |
659 |