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