1 package Test::Builder::IO::Scalar;
6 Test::Builder::IO::Scalar - A copy of IO::Scalar for Test::Builder
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.
14 L<Test::Builder> can not have dependencies on other modules without
15 careful consideration, so its simply been copied into the distribution.
17 =head1 COPYRIGHT and LICENSE
19 This file came from the "IO-stringy" Perl5 toolkit.
21 Copyright (c) 1996 by Eryq. All rights reserved.
22 Copyright (c) 1999,2001 by ZeeGee Software Inc. All rights reserved.
24 This program is free software; you can redistribute it and/or
25 modify it under the same terms as Perl itself.
30 # This is copied code, I don't care.
35 use vars qw($VERSION @ISA);
40 ### The package version, both in 1.23 style *and* usable by MakeMaker:
44 @ISA = qw(IO::Handle);
46 #==============================
54 #------------------------------
59 Return a new, unattached scalar handle.
60 If any arguments are given, they're sent to open().
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
76 #------------------------------
78 =item open [SCALARREF]
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
85 Returns the self object on success, undefined on error.
90 my ($self, $sref) = @_;
93 defined($sref) or do {my $s = ''; $sref = \$s};
94 (ref($sref) eq "SCALAR") or croak "open() needs a ref to a scalar";
97 *$self->{Pos} = 0; ### seek position
98 *$self->{SR} = $sref; ### scalar reference
102 #------------------------------
107 Is the scalar handle opened on something?
115 #------------------------------
120 Disassociate the scalar handle from its underlying scalar.
121 Done automatically on destroy.
137 #==============================
139 =head2 Input and output
146 #------------------------------
151 No-op, provided for OO compatibility.
155 sub flush { "0 but true" }
157 #------------------------------
162 Return the next character, or undef if none remain.
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);
174 #------------------------------
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".
188 ### Return undef right away if at EOF:
189 return undef if $self->eof;
192 my $sr = *$self->{SR};
193 my $i = *$self->{Pos}; ### Start matching at this point.
195 ### Minimal impact implementation!
196 ### We do the fast fast thing (no regexps) if using the
197 ### classic input record separator.
199 ### Case 1: $/ is undef: slurp all...
201 *$self->{Pos} = length $$sr;
202 return substr($$sr, $i);
205 ### Case 2: $/ is "\n": zoom zoom zoom...
206 elsif ($/ eq "\012") {
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;
214 ### Extract the 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.
220 else { ### No "\n"; slurp the remainder:
221 $line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos});
222 *$self->{Pos} = $len;
227 ### Case 3: $/ is ref to int. Do fixed-size records.
228 ### (Thanks to Dominique Quatravaux.)
230 my $len = length($$sr);
232 my $line = substr ($$sr, *$self->{Pos}, $i);
234 *$self->{Pos} = $len if (*$self->{Pos} > $len);
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
245 ### If in paragraph mode, skip leading lines (and update i!):
247 (($$sr =~ m/\G\n*/g) and ($i = pos($$sr)));
249 ### If we see the separator in the buffer ahead...
251 ? $$sr =~ m,\Q$/\E,g ### (ordinary sep) TBD: precomp!
252 : $$sr =~ m,\n\n,g ### (a paragraph)
254 *$self->{Pos} = pos $$sr;
255 return substr($$sr, $i, *$self->{Pos}-$i);
257 ### Else if no separator remains, just slurp the rest:
259 *$self->{Pos} = length $$sr;
260 return substr($$sr, $i);
265 #------------------------------
270 Get all remaining lines.
271 It will croak() if accidentally called in a scalar context.
277 wantarray or croak("can't call getlines in scalar context!");
279 push @lines, $line while (defined($line = $self->getline));
283 #------------------------------
288 Print ARGS to the underlying scalar.
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.
298 *$self->{Pos} = length(${*$self->{SR}} .= join('', @_) . (defined($\) ? $\ : ""));
303 my $append = join('', @_) . $\;
304 ${*$self->{SR}} .= $append;
305 *$self->{Pos} += length($append);
310 ${*$self->{SR}} .= join('', @_) . $\;
311 *$self->{Pos} = length(${*$self->{SR}});
316 #------------------------------
318 =item read BUF, NBYTES, [OFFSET]
321 Read some bytes from the scalar.
322 Returns the number of bytes actually read, 0 on end-of-file, undef on error.
329 my $off = $_[3] || 0;
331 my $read = substr(${*$self->{SR}}, *$self->{Pos}, $n);
334 ($off ? substr($_[1], $off) : $_[1]) = $read;
338 #------------------------------
340 =item write BUF, NBYTES, [OFFSET]
343 Write some bytes to the scalar.
350 my $off = $_[3] || 0;
352 my $data = substr($_[1], $off, $n);
358 #------------------------------
360 =item sysread BUF, LEN, [OFFSET]
363 Read some bytes from the scalar.
364 Returns the number of bytes actually read, 0 on end-of-file, undef on error.
373 #------------------------------
375 =item syswrite BUF, NBYTES, [OFFSET]
378 Write some bytes to the scalar.
392 #==============================
394 =head2 Seeking/telling and other attributes
401 #------------------------------
406 No-op, provided for OO compatibility.
412 #------------------------------
417 No-op, provided for OO compatibility.
423 #------------------------------
427 I<Instance method.> Clear the error and EOF flags. A no-op.
433 #------------------------------
437 I<Instance method.> Are we at end of file?
443 (*$self->{Pos} >= length(${*$self->{SR}}));
446 #------------------------------
448 =item seek OFFSET, WHENCE
450 I<Instance method.> Seek to a given position in the stream.
455 my ($self, $pos, $whence) = @_;
456 my $eofpos = length(${*$self->{SR}});
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)" }
465 if (*$self->{Pos} < 0) { *$self->{Pos} = 0 }
466 if (*$self->{Pos} > $eofpos) { *$self->{Pos} = $eofpos }
470 #------------------------------
472 =item sysseek OFFSET, WHENCE
474 I<Instance method.> Identical to C<seek OFFSET, WHENCE>, I<q.v.>
483 #------------------------------
488 Return the current position in the stream, as a numeric offset.
492 sub tell { *{shift()}->{Pos} }
494 #------------------------------
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.
506 my ($self, $yesno) = @_;
507 carp "use_RS is deprecated and ignored; \$/ is always consulted\n";
510 #------------------------------
515 Set the current position, using the opaque value returned by C<getpos()>.
519 sub setpos { shift->seek($_[0],0) }
521 #------------------------------
526 Return the current position in the string, as an opaque object.
533 #------------------------------
538 Return a reference to the underlying scalar.
542 sub sref { *{shift()}->{SR} }
545 #------------------------------
546 # Tied handle methods...
547 #------------------------------
549 # Conventional tiehandle interface:
551 ((defined($_[1]) && UNIVERSAL::isa($_[1], __PACKAGE__))
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(@_); }
566 #------------------------------------------------------------
581 Perl's TIEHANDLE spec was incomplete prior to 5.005_57;
582 it was missing support for C<seek()>, C<tell()>, and C<eof()>.
583 Attempting to use these functions with an IO::Scalar will not work
584 prior to 5.005_57. IO::Scalar will not have the relevant methods
585 invoked; and even worse, this kind of bug can lie dormant for a while.
586 If you turn warnings on (via C<$^W> or C<perl -w>),
587 and you see something like this...
589 attempt to seek on unopened filehandle
591 ...then you are probably trying to use one of these functions
592 on an IO::Scalar with an old Perl. The remedy is to simply
593 use the OO version; e.g.:
595 $SH->seek(0,0); ### GOOD: will work on any 5.005
596 seek($SH,0,0); ### WARNING: will only work on 5.005_57 and beyond
601 $Id: Scalar.pm,v 1.6 2005/02/10 21:21:53 dfs Exp $
606 =head2 Primary Maintainer
608 David F. Skoll (F<dfs@roaringpenguin.com>).
610 =head2 Principal author
612 Eryq (F<eryq@zeegee.com>).
613 President, ZeeGee Software Inc (F<http://www.zeegee.com>).
616 =head2 Other contributors
618 The full set of contributors always includes the folks mentioned
619 in L<IO::Stringy/"CHANGE LOG">. But just the same, special
620 thanks to the following individuals for their invaluable contributions
621 (if I've forgotten or misspelled your name, please email me!):
624 for contributing C<getc()>.
627 for suggesting C<opened()>.
630 for finding and fixing the bug in C<PRINTF()>.
633 for his offset-using read() and write() implementations.
636 for his patches to massively improve the performance of C<getline()>
637 and add C<sysread> and C<syswrite>.
639 I<B. K. Oxley (binkley),>
640 for stringification and inheritance improvements,
641 and sundry good ideas.
644 for the IO::Handle inheritance and automatic tie-ing.
649 L<IO::String>, which is quite similar but which was designed
650 more-recently and with an IO::Handle-like interface in mind,
651 so you could mix OO- and native-filehandle usage without using tied().
653 I<Note:> as of version 2.x, these classes all work like
654 their IO::Handle counterparts, so we have comparable
655 functionality to IO::String.