File Coverage

lib/IO/ScalarArray.pm
Criterion Covered Total %
statement 133 160 83.1
branch 36 50 72.0
condition 8 16 50.0
subroutine 27 43 62.7
pod 21 21 100.0
total 225 290 77.5


line stmt bran cond sub pod time code
1             package IO::ScalarArray;
2              
3 3     3   1895 use strict;
  3         9  
  3         70  
4 3     3   11 use Carp;
  3         6  
  3         162  
5 3     3   925 use IO::Handle;
  3         10775  
  3         5401  
6              
7             # The package version, both in 1.23 style *and* usable by MakeMaker:
8             our $VERSION = "2.112";
9              
10             # Inheritance:
11             our @ISA = qw(IO::Handle);
12             require IO::WrapTie and push @ISA, 'IO::WrapTie::Slave' if ($] >= 5.004);
13              
14             =head1 NAME
15              
16             IO::ScalarArray - IO:: interface for reading/writing an array of scalars
17              
18              
19             =head1 SYNOPSIS
20              
21             Perform 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              
57             Don't like OO for your I/O? No problem.
58             Thanks to the magic of an invisible tie(), the following now
59             works 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              
93             And for you folks with 1.x code out there: the old tie() style still works,
94             though this is I:
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 () {
109             print "Got line: ", $_;
110             }
111              
112              
113              
114             =head1 DESCRIPTION
115              
116             This class is part of the IO::Stringy distribution;
117             see L for change log and general information.
118              
119             The IO::ScalarArray 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) arrays of scalars. Logically, an
122             array of scalars defines an in-core "file" whose contents are
123             the concatenation of the scalars in the array. The handles created by
124             this class are automatically tiehandle'd (though please see L<"WARNINGS">
125             for information relevant to your Perl version).
126              
127             For writing large amounts of data with individual print() statements,
128             this class is likely to be more efficient than IO::Scalar.
129              
130             Basically, 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              
137             Or 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              
144             Causes @a to be set to the following array of 3 strings:
145              
146             ( "Hel" ,
147             "lo, " ,
148             "world!\n" )
149              
150             See L 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              
165             I
166             Return a new, unattached array handle.
167             If any arguments are given, they're sent to open().
168              
169             =cut
170              
171             sub new {
172 12     12 1 1751 my $proto = shift;
173 12   33     40 my $class = ref($proto) || $proto;
174 12         14 my $self = bless \do { local *FH }, $class;
  12         39  
175 12         92 tie *$self, $class, $self;
176 12         33 $self->open(@_); ### open on anonymous by default
177 12         32 $self;
178             }
179             sub DESTROY {
180 10     10   312 shift->close;
181             }
182              
183              
184             #------------------------------
185              
186             =item open [ARRAYREF]
187              
188             I
189             Open the array handle on a new array, pointed to by ARRAYREF.
190             If no ARRAYREF is given, a "private" array is created to hold
191             the file data.
192              
193             Returns the self object on success, undefined on error.
194              
195             =cut
196              
197             sub open {
198 12     12 1 20 my ($self, $aref) = @_;
199              
200             ### Sanity:
201 12 100       22 defined($aref) or do {my @a; $aref = \@a};
  2         3  
  2         2  
202 12 50       24 (ref($aref) eq "ARRAY") or croak "open needs a ref to a array";
203              
204             ### Setup:
205 12         46 $self->setpos([0,0]);
206 12         28 *$self->{AR} = $aref;
207 12         22 $self;
208             }
209              
210             #------------------------------
211              
212             =item opened
213              
214             I
215             Is the array handle opened on something?
216              
217             =cut
218              
219             sub opened {
220 0     0 1 0 *{shift()}->{AR};
  0         0  
221             }
222              
223             #------------------------------
224              
225             =item close
226              
227             I
228             Disassociate the array handle from its underlying array.
229             Done automatically on destroy.
230              
231             =cut
232              
233             sub close {
234 10     10 1 26 my $self = shift;
235 10         11 %{*$self} = ();
  10         27  
236 10         32 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              
257             I
258             No-op, provided for OO compatibility.
259              
260             =cut
261              
262 0     0 1 0 sub flush { "0 but true" }
263              
264             #------------------------------
265              
266             =item fileno
267              
268             I
269             No-op, returns undef
270              
271             =cut
272              
273       1 1   sub fileno { }
274              
275             #------------------------------
276              
277             =item getc
278              
279             I
280             Return the next character, or undef if none remain.
281             This does a read(1), which is somewhat costly.
282              
283             =cut
284              
285             sub getc {
286 6     6 1 29 my $buf = '';
287 6 50       13 ($_[0]->read($buf, 1) ? $buf : undef);
288             }
289              
290             #------------------------------
291              
292             =item getline
293              
294             I
295             Return the next line, or undef on end of data.
296             Can safely be called in an array context.
297             Currently, lines are delimited by "\n".
298              
299             =cut
300              
301             sub getline {
302 41     41 1 894 my $self = shift;
303 41         48 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 41 100       78 if (!defined($/)) {
    50          
    0          
312              
313 2 50       4 return undef if ($self->eof);
314              
315             ### Get the rest of the current string, followed by remaining strings:
316 2         3 my $ar = *$self->{AR};
317             my @slurp = (
318             substr($ar->[*$self->{Str}], *$self->{Pos}),
319 2         12 @$ar[(1 + *$self->{Str}) .. $#$ar ]
320             );
321              
322             ### Seek to end:
323 2         14 $self->_setpos_to_eof;
324 2         12 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 39         75 until ($self->eof) {
332             ### If at end of current string, go fwd to next one (won't be EOF):
333 47 100       56 if ($self->_eos) {++*$self->{Str}, *$self->{Pos}=0};
  28         45  
334              
335             ### Get ref to current string in array, and set internal pos mark:
336 47         90 $str = \(*$self->{AR}[*$self->{Str}]); ### get current string
337 47         89 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 47         180 $$str =~ m/\G(.*?)((\n)|\Z)/g; ### match to 1st \n or EOS
341 47         92 $line .= $1.$2; ### add it
342 47         81 *$self->{Pos} += length($1.$2); ### move fwd by len matched
343 47 100       141 return $line if $3; ### done, got line with "\n"
344             }
345 7 100       18 return ($line eq '') ? undef : $line; ### return undef if EOF
346             }
347              
348             ### Case 3: $/ is ref to int. Bail out.
349             elsif (ref($/)) {
350 0         0 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 0         0 croak '$/ as given is currently unsupported';
357             }
358             }
359              
360             #------------------------------
361              
362             =item getlines
363              
364             I
365             Get all remaining lines.
366             It will croak() if accidentally called in a scalar context.
367              
368             =cut
369              
370             sub getlines {
371 2     2 1 4 my $self = shift;
372 2 50       13 wantarray or croak("can't call getlines in scalar context!");
373 2         3 my ($line, @lines);
374 2         5 push @lines, $line while (defined($line = $self->getline));
375 2         7 @lines;
376             }
377              
378             #------------------------------
379              
380             =item print ARGS...
381              
382             I
383             Print ARGS to the underlying array.
384              
385             Currently, this always causes a "seek to the end of the array"
386             and generates a new array entry. This may change in the future.
387              
388             =cut
389              
390             sub print {
391 7     7 1 20 my $self = shift;
392 7 50       5 push @{*$self->{AR}}, join('', @_) . (defined($\) ? $\ : ""); ### add the data
  7         43  
393 7         18 $self->_setpos_to_eof;
394 7         13 1;
395             }
396              
397             #------------------------------
398              
399             =item read BUF, NBYTES, [OFFSET];
400              
401             I
402             Read some bytes from the array.
403             Returns the number of bytes actually read, 0 on end-of-file, undef on error.
404              
405             =cut
406              
407             sub read {
408 18     18 1 96 my $self = $_[0];
409             ### we must use $_[1] as a ref
410 18         26 my $n = $_[2];
411 18   50     37 my $off = $_[3] || 0;
412              
413             ### print "getline\n";
414 18         17 my $justread;
415             my $len;
416 18 50       34 ($off ? substr($_[1], $off) : $_[1]) = '';
417              
418             ### Stop when we have zero bytes to go, or when we hit EOF:
419 18         18 my @got;
420 18   100     46 until (!$n or $self->eof) {
421             ### If at end of current string, go forward to next one (won't be EOF):
422 30 100       41 if ($self->_eos) {
423 12         14 ++*$self->{Str};
424 12         15 *$self->{Pos} = 0;
425             }
426              
427             ### Get longest possible desired substring of current string:
428 30         74 $justread = substr(*$self->{AR}[*$self->{Str}], *$self->{Pos}, $n);
429 30         32 $len = length($justread);
430 30         38 push @got, $justread;
431 30         25 $n -= $len;
432 30         61 *$self->{Pos} += $len;
433             }
434 18         29 $_[1] .= join('', @got);
435 18         57 return length($_[1])-$off;
436             }
437              
438             #------------------------------
439              
440             =item write BUF, NBYTES, [OFFSET];
441              
442             I
443             Write some bytes into the array.
444              
445             =cut
446              
447             sub write {
448 0     0 1 0 my $self = $_[0];
449 0         0 my $n = $_[2];
450 0   0     0 my $off = $_[3] || 0;
451              
452 0         0 my $data = substr($_[1], $n, $off);
453 0         0 $n = length($data);
454 0         0 $self->print($data);
455 0         0 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              
477             I
478             No-op, provided for OO compatibility.
479              
480             =cut
481              
482       0 1   sub autoflush {}
483              
484             #------------------------------
485              
486             =item binmode
487              
488             I
489             No-op, provided for OO compatibility.
490              
491             =cut
492              
493       0 1   sub binmode {}
494              
495             #------------------------------
496              
497             =item clearerr
498              
499             I Clear the error and EOF flags. A no-op.
500              
501             =cut
502              
503 0     0 1 0 sub clearerr { 1 }
504              
505             #------------------------------
506              
507             =item eof
508              
509             I Are we at end of file?
510              
511             =cut
512              
513             sub eof {
514             ### print "checking EOF [*$self->{Str}, *$self->{Pos}]\n";
515             ### print "SR = ", $#{*$self->{AR}}, "\n";
516              
517 88 100   88 1 69 return 0 if (*{$_[0]}->{Str} < $#{*{$_[0]}->{AR}}); ### before EOA
  88         1634  
  88         67  
  88         240  
518 13 50       14 return 1 if (*{$_[0]}->{Str} > $#{*{$_[0]}->{AR}}); ### after EOA
  13         19  
  13         12  
  13         20  
519             ### ### at EOA, past EOS:
520 13 50       14 ((*{$_[0]}->{Str} == $#{*{$_[0]}->{AR}}) && ($_[0]->_eos));
  13         32  
  13         12  
  13         33  
521             }
522              
523             #------------------------------
524             #
525             # _eos
526             #
527             # I Are we at end of the CURRENT string?
528             #
529             sub _eos {
530 90     90   68 (*{$_[0]}->{Pos} >= length(*{$_[0]}->{AR}[*{$_[0]}->{Str}])); ### past last char
  90         104  
  90         220  
  90         95  
531             }
532              
533             #------------------------------
534              
535             =item seek POS,WHENCE
536              
537             I
538             Seek to a given position in the stream.
539             Only a WHENCE of 0 (SEEK_SET) is supported.
540              
541             =cut
542              
543             sub seek {
544 22     22 1 1489 my ($self, $pos, $whence) = @_;
545              
546             ### Seek:
547 22 100       47 if ($whence == 0) { $self->_seek_set($pos); }
  18 100       29  
    50          
548 2         7 elsif ($whence == 1) { $self->_seek_cur($pos); }
549 2         8 elsif ($whence == 2) { $self->_seek_end($pos); }
550 0         0 else { croak "bad seek whence ($whence)" }
551 22         45 return 1;
552             }
553              
554             #------------------------------
555             #
556             # _seek_set POS
557             #
558             # Instance method, private.
559             # Seek to $pos relative to start:
560             #
561             sub _seek_set {
562 22     22   23 my ($self, $pos) = @_;
563              
564             ### Advance through array until done:
565 22         23 my $istr = 0;
566 22   33     43 while (($pos >= 0) && ($istr < scalar(@{*$self->{AR}}))) {
  44         111  
567 44 100       92 if (length(*$self->{AR}[$istr]) > $pos) { ### it's in this string!
568 22         47 return $self->setpos([$istr, $pos]);
569             }
570             else { ### it's in next string
571 22         37 $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 0         0 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             #
585             sub _seek_cur {
586 2     2   4 my ($self, $pos) = @_;
587 2         5 $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             #
598             sub _seek_end {
599 2     2   4 my ($self, $pos) = @_;
600 2         7 $self->_seek_set($self->_tell_eof + $pos);
601             }
602              
603             #------------------------------
604              
605             =item tell
606              
607             I
608             Return the current position in the stream, as a numeric offset.
609              
610             =cut
611              
612             sub tell {
613 4     4 1 65 my $self = shift;
614 4         5 my $off = 0;
615 4         5 my ($s, $str_s);
616 4         17 for ($s = 0; $s < *$self->{Str}; $s++) { ### count all "whole" scalars
617 12 50       38 defined($str_s = *$self->{AR}[$s]) or $str_s = '';
618             ###print STDERR "COUNTING STRING $s (". length($str_s) . ")\n";
619 12         20 $off += length($str_s);
620             }
621             ###print STDERR "COUNTING POS ($self->{Pos})\n";
622 4         34 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             #
633             sub _tell_eof {
634 2     2   3 my $self = shift;
635 2         3 my $len = 0;
636 2         12 foreach (@{*$self->{AR}}) { $len += length($_) }
  2         10  
  13         14  
637 2         6 $len;
638             }
639              
640             #------------------------------
641              
642             =item setpos POS
643              
644             I
645             Seek to a given position in the array, using the opaque getpos() value.
646             Don't expect this to be a number.
647              
648             =cut
649              
650             sub setpos {
651 43     43 1 54 my ($self, $pos) = @_;
652 43 50       74 (ref($pos) eq 'ARRAY') or
653             die "setpos: only use a value returned by getpos!\n";
654 43         114 (*$self->{Str}, *$self->{Pos}) = @$pos;
655             }
656              
657             #------------------------------
658             #
659             # _setpos_to_eof
660             #
661             # Fast-forward to EOF.
662             #
663             sub _setpos_to_eof {
664 9     9   10 my $self = shift;
665 9         6 $self->setpos([scalar(@{*$self->{AR}}), 0]);
  9         24  
666             }
667              
668             #------------------------------
669              
670             =item getpos
671              
672             I
673             Return the current position in the array, as an opaque value.
674             Don't expect this to be a number.
675              
676             =cut
677              
678             sub getpos {
679 0     0 1 0 [*{$_[0]}->{Str}, *{$_[0]}->{Pos}];
  0         0  
  0         0  
680             }
681              
682             #------------------------------
683              
684             =item aref
685              
686             I
687             Return a reference to the underlying array.
688              
689             =cut
690              
691             sub aref {
692 2     2 1 10 *{shift()}->{AR};
  2         10  
693             }
694              
695             =back
696              
697             =cut
698              
699             #------------------------------
700             # Tied handle methods...
701             #------------------------------
702              
703             ### Conventional tiehandle interface:
704 14 100 66 14   180 sub TIEHANDLE { (defined($_[1]) && UNIVERSAL::isa($_[1],"IO::ScalarArray"))
705             ? $_[1]
706             : shift->new(@_) }
707 0     0   0 sub GETC { shift->getc(@_) }
708 10     10   201 sub PRINT { shift->print(@_) }
709 0     0   0 sub PRINTF { shift->print(sprintf(shift, @_)) }
710 0     0   0 sub READ { shift->read(@_) }
711 16 100   16   85 sub READLINE { wantarray ? shift->getlines(@_) : shift->getline(@_) }
712 0     0     sub WRITE { shift->write(@_); }
713 0     0     sub CLOSE { shift->close(@_); }
714 0     0     sub SEEK { shift->seek(@_); }
715 0     0     sub TELL { shift->tell(@_); }
716 0     0     sub EOF { shift->eof(@_); }
717 0     0     sub BINMODE { 1; }
718              
719             #------------------------------------------------------------
720              
721             1;
722             __END__