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