root/trunk/inc/Test/Builder/IO/Scalar.pm

Revision 100, 13.3 kB (checked in by clinton, 4 years ago)

Add Test::More to inc bundle

Line 
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 IO::Scalar which ships with 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 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.110";
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 curent 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(@_); }
565
566 #------------------------------------------------------------
567
568 1;
569
570 __END__
571
572
573
574 =back
575
576 =cut
577
578
579 =head1 WARNINGS
580
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...
588
589     attempt to seek on unopened filehandle
590
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.:
594
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
597
598
599 =head1 VERSION
600
601 $Id: Scalar.pm,v 1.6 2005/02/10 21:21:53 dfs Exp $
602
603
604 =head1 AUTHORS
605
606 =head2 Primary Maintainer
607
608 David F. Skoll (F<dfs@roaringpenguin.com>).
609
610 =head2 Principal author
611
612 Eryq (F<eryq@zeegee.com>).
613 President, ZeeGee Software Inc (F<http://www.zeegee.com>).
614
615
616 =head2 Other contributors
617
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!):
622
623 I<Andy Glew,>
624 for contributing C<getc()>.
625
626 I<Brandon Browning,>
627 for suggesting C<opened()>.
628
629 I<David Richter,>
630 for finding and fixing the bug in C<PRINTF()>.
631
632 I<Eric L. Brine,>
633 for his offset-using read() and write() implementations.
634
635 I<Richard Jones,>
636 for his patches to massively improve the performance of C<getline()>
637 and add C<sysread> and C<syswrite>.
638
639 I<B. K. Oxley (binkley),>
640 for stringification and inheritance improvements,
641 and sundry good ideas.
642
643 I<Doug Wilson,>
644 for the IO::Handle inheritance and automatic tie-ing.
645
646
647 =head1 SEE ALSO
648
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().
652
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.
656
657 =cut
658
Note: See TracBrowser for help on using the browser.