File Coverage

lib/Test/Builder/IO/Scalar.pm
Criterion Covered Total %
statement 14 151 9.2
branch 0 46 0.0
condition 0 13 0.0
subroutine 5 43 11.6
pod 23 23 100.0
total 42 276 15.2


line stmt bran cond sub pod time code
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 1     1   491 use Carp;
  1         2  
  1         65  
34 1     1   6 use strict;
  1         3  
  1         25  
35 1     1   5 use vars qw($VERSION @ISA);
  1         1  
  1         60  
36 1     1   584 use IO::Handle;
  1         5217  
  1         40  
37              
38 1     1   20 use 5.005;
  1         3  
39              
40             ### The package version, both in 1.23 style *and* usable by MakeMaker:
41             $VERSION = "2.114";
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 0     0 1   my $proto = shift;
66 0   0       my $class = ref($proto) || $proto;
67 0           my $self = bless \do { local *FH }, $class;
  0            
68 0           tie *$self, $class, $self;
69 0           $self->open(@_); ### open on anonymous by default
70 0           $self;
71             }
72             sub DESTROY {
73 0     0     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 0     0 1   my ($self, $sref) = @_;
91              
92             ### Sanity:
93 0 0         defined($sref) or do {my $s = ''; $sref = \$s};
  0            
  0            
94 0 0         (ref($sref) eq "SCALAR") or croak "open() needs a ref to a scalar";
95              
96             ### Setup:
97 0           *$self->{Pos} = 0; ### seek position
98 0           *$self->{SR} = $sref; ### scalar reference
99 0           $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 0     0 1   *{shift()}->{SR};
  0            
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 0     0 1   my $self = shift;
127 0           %{*$self} = ();
  0            
128 0           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 0     0 1   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 0     0 1   my $self = shift;
168              
169             ### Return undef right away if at EOF; else, move pos forward:
170 0 0         return undef if $self->eof;
171 0           substr(${*$self->{SR}}, *$self->{Pos}++, 1);
  0            
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 0     0 1   my $self = shift;
187              
188             ### Return undef right away if at EOF:
189 0 0         return undef if $self->eof;
190              
191             ### Get next line:
192 0           my $sr = *$self->{SR};
193 0           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 0 0         if (!defined($/)) {
    0          
    0          
201 0           *$self->{Pos} = length $$sr;
202 0           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 0           my $len = length($$sr);
210 0           for (; $i < $len; ++$i) {
211 0 0         last if ord (substr ($$sr, $i, 1)) == 10;
212             }
213              
214             ### Extract the line:
215 0           my $line;
216 0 0         if ($i < $len) { ### We found a "\n":
217 0           $line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos} + 1);
218 0           *$self->{Pos} = $i+1; ### Remember where we finished up.
219             }
220             else { ### No "\n"; slurp the remainder:
221 0           $line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos});
222 0           *$self->{Pos} = $len;
223             }
224 0           return $line;
225             }
226              
227             ### Case 3: $/ is ref to int. Do fixed-size records.
228             ### (Thanks to Dominique Quatravaux.)
229             elsif (ref($/)) {
230 0           my $len = length($$sr);
231 0           my $i = ${$/} + 0;
  0            
232 0           my $line = substr ($$sr, *$self->{Pos}, $i);
233 0           *$self->{Pos} += $i;
234 0 0         *$self->{Pos} = $len if (*$self->{Pos} > $len);
235 0           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 0           pos($$sr) = $i;
244              
245             ### If in paragraph mode, skip leading lines (and update i!):
246 0 0 0       length($/) or
247             (($$sr =~ m/\G\n*/g) and ($i = pos($$sr)));
248              
249             ### If we see the separator in the buffer ahead...
250 0 0         if (length($/)
    0          
251             ? $$sr =~ m,\Q$/\E,g ### (ordinary sep) TBD: precomp!
252             : $$sr =~ m,\n\n,g ### (a paragraph)
253             ) {
254 0           *$self->{Pos} = pos $$sr;
255 0           return substr($$sr, $i, *$self->{Pos}-$i);
256             }
257             ### Else if no separator remains, just slurp the rest:
258             else {
259 0           *$self->{Pos} = length $$sr;
260 0           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 0     0 1   my $self = shift;
277 0 0         wantarray or croak("can't call getlines in scalar context!");
278 0           my ($line, @lines);
279 0           push @lines, $line while (defined($line = $self->getline));
280 0           @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 0     0 1   my $self = shift;
298 0 0         *$self->{Pos} = length(${*$self->{SR}} .= join('', @_) . (defined($\) ? $\ : ""));
  0            
299 0           1;
300             }
301             sub _unsafe_print {
302 0     0     my $self = shift;
303 0           my $append = join('', @_) . $\;
304 0           ${*$self->{SR}} .= $append;
  0            
305 0           *$self->{Pos} += length($append);
306 0           1;
307             }
308             sub _old_print {
309 0     0     my $self = shift;
310 0           ${*$self->{SR}} .= join('', @_) . $\;
  0            
311 0           *$self->{Pos} = length(${*$self->{SR}});
  0            
312 0           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 0     0 1   my $self = $_[0];
328 0           my $n = $_[2];
329 0   0       my $off = $_[3] || 0;
330              
331 0           my $read = substr(${*$self->{SR}}, *$self->{Pos}, $n);
  0            
332 0           $n = length($read);
333 0           *$self->{Pos} += $n;
334 0 0         ($off ? substr($_[1], $off) : $_[1]) = $read;
335 0           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 0     0 1   my $self = $_[0];
349 0           my $n = $_[2];
350 0   0       my $off = $_[3] || 0;
351              
352 0           my $data = substr($_[1], $off, $n);
353 0           $n = length($data);
354 0           $self->print($data);
355 0           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 0     0 1   my $self = shift;
370 0           $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 0     0 1   my $self = shift;
384 0           $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       0 1   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       0 1   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 0     0 1   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 0     0 1   my $self = shift;
443 0           (*$self->{Pos} >= length(${*$self->{SR}}));
  0            
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 0     0 1   my ($self, $pos, $whence) = @_;
456 0           my $eofpos = length(${*$self->{SR}});
  0            
457              
458             ### Seek:
459 0 0         if ($whence == 0) { *$self->{Pos} = $pos } ### SEEK_SET
  0 0          
    0          
460 0           elsif ($whence == 1) { *$self->{Pos} += $pos } ### SEEK_CUR
461 0           elsif ($whence == 2) { *$self->{Pos} = $eofpos + $pos} ### SEEK_END
462 0           else { croak "bad seek whence ($whence)" }
463              
464             ### Fixup:
465 0 0         if (*$self->{Pos} < 0) { *$self->{Pos} = 0 }
  0            
466 0 0         if (*$self->{Pos} > $eofpos) { *$self->{Pos} = $eofpos }
  0            
467 0           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 0     0 1   my $self = shift;
480 0           $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 0     0 1   sub tell { *{shift()}->{Pos} }
  0            
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 0     0 1   my ($self, $yesno) = @_;
507 0           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 0     0 1   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 0     0 1   sub sref { *{shift()}->{SR} }
  0            
543              
544              
545             #------------------------------
546             # Tied handle methods...
547             #------------------------------
548              
549             # Conventional tiehandle interface:
550             sub TIEHANDLE {
551 0 0 0 0     ((defined($_[1]) && UNIVERSAL::isa($_[1], __PACKAGE__))
552             ? $_[1]
553             : shift->new(@_));
554             }
555 0     0     sub GETC { shift->getc(@_) }
556 0     0     sub PRINT { shift->print(@_) }
557 0     0     sub PRINTF { shift->print(sprintf(shift, @_)) }
558 0     0     sub READ { shift->read(@_) }
559 0 0   0     sub READLINE { wantarray ? shift->getlines(@_) : shift->getline(@_) }
560 0     0     sub WRITE { shift->write(@_); }
561 0     0     sub CLOSE { shift->close(@_); }
562 0     0     sub SEEK { shift->seek(@_); }
563 0     0     sub TELL { shift->tell(@_); }
564 0     0     sub EOF { shift->eof(@_); }
565 0     0     sub FILENO { -1 }
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