File Coverage

blib/lib/IO/Handle/Iterator.pm
Criterion Covered Total %
statement 67 94 71.2
branch 13 20 65.0
condition 2 3 66.6
subroutine 19 41 46.3
pod 0 27 0.0
total 101 185 54.5


line stmt bran cond sub pod time code
1             package IO::Handle::Iterator;
2              
3 2     2   29457 use strict;
  2         5  
  2         74  
4 2     2   11 use warnings;
  2         5  
  2         66  
5              
6 2     2   12 use Carp ();
  2         4  
  2         44  
7              
8 2     2   1725 use parent qw(IO::Handle::Prototype);
  2         615  
  2         10  
9              
10             # error, clearerr, new_from_fd, fdopen
11              
12             sub new {
13 8     8 0 47 my ( $class, $cb ) = @_;
14              
15 8         51 bless {
16             cb => $cb,
17             }, $class;
18             }
19              
20 24     24 0 57 sub getline { shift->_cb }
21              
22             sub _cb {
23 31     31   40 my $self = shift;
24              
25 31 50       212 if ( my $cb = $self->{cb} ) {
26 31 100       83 if ( defined(my $next = $cb->()) ) {
27 23         97 return $next;
28             } else {
29 8         36 $self->close;
30             }
31             }
32              
33 8         50 return;
34             }
35              
36             sub _rebless_and {
37 2     2   4 my $self = shift;
38 2         3 my $method = shift;
39              
40 2         8 bless $self, "IO::Handle::Iterator::Buffered";
41              
42 2         10 $self->$method(@_);
43             }
44              
45 2     2 0 10 sub read { shift->_rebless_and( read => @_ ) }
46 0     0 0 0 sub sysread { shift->_rebless_and( sysread => @_ ) }
47 0     0 0 0 sub getc { shift->_rebless_and( getc => @_ ) }
48 0     0 0 0 sub ungetc { shift->_rebless_and( ungetc => @_ ) }
49              
50 0     0 0 0 sub open { Carp::croak("Can't open an iterator") }
51 0     0 0 0 sub print { Carp::croak("Can't print to iterator") }
52 0     0 0 0 sub printflush { Carp::croak("Can't print to iterator") }
53 0     0 0 0 sub printf { Carp::croak("Can't print to iterator") }
54 0     0 0 0 sub say { Carp::croak("Can't print to iterator") }
55 0     0 0 0 sub write { Carp::croak("Can't write to iterator") }
56 0     0 0 0 sub syswrite { Carp::croak("Can't write to iterator") }
57 0     0 0 0 sub format_write { Carp::croak("Can't write to iterator") }
58 0     0 0 0 sub ioctl { Carp::croak("Can't ioctl on iterator") }
59 0     0 0 0 sub fcntl { Carp::croak("Can't fcntl on iterator") }
60 0     0 0 0 sub truncate { Carp::croak("Can't truncate iterator") }
61 0     0 0 0 sub sync { Carp::croak("Can't sync an iterator") }
62 0     0 0 0 sub flush { Carp::croak("Can't flush an iterator") }
63              
64 0     0 0 0 sub autoflush { 1 }
65              
66 0     0 0 0 sub opened { 1 }
67              
68             sub blocking {
69 0     0 0 0 my ( $self, @args ) = @_;
70              
71 0 0       0 Carp::croak("Can't set blocking mode on iterator") if @args;
72              
73 0         0 return 1;
74             }
75              
76 0     0 0 0 sub stat { return undef }
77 0     0 0 0 sub fileno { return undef }
78              
79 8     8 0 25 sub close { delete $_[0]{cb} }
80 15     15 0 3865 sub eof { not exists $_[0]{cb} }
81              
82             sub getlines {
83 4     4 0 6 my $self = shift;
84              
85 4         6 my @accum;
86            
87 4         10 while ( defined(my $next = $self->getline) ) {
88 8         23 push @accum, $next;
89             }
90              
91 4         32 return @accum;
92             }
93              
94             package IO::Handle::Iterator::Buffered; # FIXME IO::Handle::BufferMixin?
95 2     2   1818 use parent qw(IO::Handle::Iterator);
  2         5  
  2         12  
96              
97 2     2   139 no warnings 'uninitialized';
  2         4  
  2         1119  
98              
99             sub eof {
100 13     13   20 my $self = shift;
101              
102 13 100       228 length($self->{buf}) == 0
103             and
104             $self->SUPER::eof;
105             }
106              
107             sub getc {
108 2     2   6 shift->read(my $c, 1);
109 2         10 return $c;
110             }
111              
112             sub ungetc {
113 1     1   3 my ( $self, $ord ) = @_;
114 1         5 substr($self->{buf}, 0, 0, chr($ord)); # yuck
115 1         2 return;
116             }
117              
118 0     0   0 sub sysread { shift->read(@_) }
119              
120             sub read {
121 6     6   15 my ( $self, undef, $length, $offset ) = @_;
122              
123 6 50       14 return 0 if $self->eof;
124              
125 6 100 66     22 if ( $offset and length($_[1]) < $offset ) {
126 1         4 $_[1] .= "\0" x ( $offset - length($_[1]) );
127             }
128              
129 6         20 while (length($self->{buf}) < $length) {
130 7 100       18 if ( defined(my $next = $self->_cb) ) {
131 6         25 $self->{buf} .= $next;
132             } else {
133             # data ended but still under $length, return all that remains and
134             # empty the buffer
135 1         3 my $ret = length($self->{buf});
136              
137 1 50       5 if ( $offset ) {
138 1         4 substr($_[1], $offset) = delete $self->{buf};
139             } else {
140 0         0 $_[1] = delete $self->{buf};
141             }
142              
143 1         7 return $ret;
144             }
145             }
146              
147 5         6 my $read;
148 5 50       12 if ( $length > length($self->{buf}) ) {
149 0         0 $read = delete $self->{buf};
150             } else {
151 5         53 $read = substr($self->{buf}, 0, $length, '');
152             }
153              
154 5 50       12 if ( $offset ) {
155 0         0 substr($_[1], $offset) = $read;
156             } else {
157 5         11 $_[1] = $read;
158             }
159              
160 5         18 return length($read);
161             }
162              
163             sub getline {
164 1     1   3 my $self = shift;
165              
166 1         5 my $line = delete $self->{buf};
167              
168 1         4 bless $self, 'IO::Handle::Iterator';
169              
170 1         6 return $line;
171             }
172              
173             __PACKAGE__
174              
175             # ex: set sw=4 et:
176              
177             __END__
178              
179             =head1 NAME
180              
181             IO::Handle::Iterator - Iterator based read handle
182              
183             =head1 SYNOPSIS
184              
185             IO::Handle::Iterator->new(sub {
186             return $next_line; # or undef on eof
187             });
188              
189             =head1 DESCRIPTION
190              
191             This class lets you define a read handle with a few fallback methods (like
192             C<read>) using a single callback that behaves like C<getline>.
193              
194             This is similar but much simpler than:
195              
196             IO::Handle::Prototype::Fallback->new(
197             __read => sub { ... },
198             );
199              
200             The reason being that the L<IO::Handle::Prototype::Fallback> implementation
201             will try its very best to behave correctly (i.e. respect the value of C<$/>),
202             whereas this implementation assumes it's fine to return things that aren't
203             exactly lines from C<getline>, so the values are just passed through.
204              
205             =head1 READ BUFFERING
206              
207             When a method that requires buffering is invoked the handle is reblessed to a
208             subclass which handles buffering.
209              
210             Calling C<getline> again on this object will return the value of the buffer and
211             return to the normal iterator class.
212