cpan/Test-Simple/lib/Test/Builder/IO/Scalar.pm

   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(@_); }
 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