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

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