vcs.maemo.org Git - pkg-perl/blob - deb-src/libio-stringy-perl/io-stringy-2.110/lib/IO/Scalar.pm

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