File Coverage

lib/Data/Handle.pm
Criterion Covered Total %
statement 156 161 96.8
branch 40 44 90.9
condition 7 9 77.7
subroutine 37 37 100.0
pod 1 1 100.0
total 241 252 95.6


line stmt bran cond sub pod time code
1 5     5   72123 use 5.006;
  5         14  
  5         160  
2 5     5   19 use strict;
  5         6  
  5         126  
3 5     5   20 use warnings;
  5         6  
  5         425  
4              
5             package Data::Handle;
6              
7             our $VERSION = '1.000000';
8              
9             # ABSTRACT: A Very simple interface to the __DATA__ file handle.
10              
11             our $AUTHORITY = 'cpan:KENTNL'; # AUTHORITY
12              
13              
14              
15              
16              
17              
18              
19              
20              
21              
22              
23              
24              
25              
26              
27              
28              
29              
30              
31              
32              
33              
34              
35              
36              
37              
38              
39              
40              
41              
42              
43              
44              
45              
46              
47              
48              
49              
50              
51              
52              
53              
54              
55              
56              
57              
58              
59              
60              
61              
62              
63              
64              
65              
66              
67              
68              
69              
70              
71              
72              
73              
74              
75              
76              
77              
78              
79              
80              
81              
82              
83              
84              
85              
86              
87              
88              
89              
90              
91              
92              
93              
94              
95              
96              
97             my %datastash;
98 5     5   2385 use Symbol qw( gensym );
  5         3395  
  5         298  
99 5     5   23 use Scalar::Util qw( weaken );
  5         5  
  5         418  
100 5     5   1952 use parent qw( IO::File );
  5         1264  
  5         23  
101 5     5   35146 use Package::Stash 0.15; # has_symbol
  5         23848  
  5         114  
102 5     5   25 use Carp ();
  5         5  
  5         62  
103 5     5   1697 use Data::Handle::Exception;
  5         12  
  5         126  
104 5     5   1831 use Data::Handle::IO;
  5         9  
  5         130  
105 5     5   24 use Try::Tiny qw( try catch );
  5         4  
  5         6020  
106              
107              
108              
109              
110              
111              
112              
113              
114              
115             sub new {
116 28     28 1 15824 my ( $class, $targetpackage ) = @_;
117              
118 28 100       86 _e('NoSymbol')->throw("$targetpackage has no DATA symbol")
119             if ( !$class->_has_data_symbol($targetpackage) );
120              
121 27 100       94 if ( !$class->_is_valid_data_tell($targetpackage) ) {
122 1         4 _e('BadFilePos')
123             ->throw( "$targetpackage has a DATA symbol, but the filepointer"
124             . " is well beyond the __DATA__ section.\n"
125             . " We can't work out safely where it is.\n"
126             . $class->_stringify_metadata($targetpackage)
127             . "\n" );
128             }
129              
130 26         85 my $sym = gensym();
131 26         303 my $xsym = $sym;
132 26         69 weaken($xsym);
133              
134             ## no critic( ProhibitTies )
135 26         37 tie *{$sym}, 'Data::Handle::IO', { self => $xsym };
  26         228  
136 26         37 ${ *{$sym} }{stash} = {};
  26         26  
  26         103  
137 26         49 bless $sym, $class;
138 26         89 $sym->_stash->{start_offset} = $class->_get_start_offset($targetpackage);
139 26         51 $sym->_stash->{targetpackage} = $targetpackage;
140 26         58 $sym->_stash->{current_offset} = $class->_get_start_offset($targetpackage);
141 26         66 $sym->_stash->{filehandle} = $class->_get_data_symbol($targetpackage);
142 26         116 return $sym;
143              
144             }
145              
146             sub _has_data_symbol {
147 73     73   105 my ( undef, $package ) = @_;
148 73         105 my $rval = undef;
149             try {
150 73     73   2066 my $stash = Package::Stash->new($package);
151 70 100       543 return unless $stash->has_symbol('DATA');
152 69         249 my $fh = $stash->get_symbol('DATA');
153 69         86 $rval = defined fileno *{$fh};
  69         418  
154             }
155             catch {
156 3 50   3   37 if (/is not a module name/) {
157 3         4 $rval = undef;
158 3         9 return;
159             }
160             ## no critic (RequireCarping)
161 0         0 die $_;
162 73         414 };
163 73         962 return $rval;
164             }
165              
166             sub _get_data_symbol {
167 35     35   128 my ( $self, $package ) = @_;
168 35 100       63 if ( !$self->_has_data_symbol($package) ) {
169 1         5 _e('Internal::BadGet')->throw('_get_data_symbol was called when there is no data_symbol to get');
170             }
171 34         316 return Package::Stash->new($package)->get_symbol('DATA');
172             }
173              
174             sub _get_start_offset {
175 57     57   204 my ( $self, $package ) = @_;
176              
177 57 100       248 return $datastash{$package}->{offset}
178             if ( exists $datastash{$package}->{offset} );
179              
180 5 100       15 if ( !$self->_has_data_symbol($package) ) {
181 1         3 _e('Internal::BadGet')->throw('_get_start_offset was called when there is no data_symbol to get');
182             }
183 4         14 my $fd = $self->_get_data_symbol($package);
184 4         17 my $position = tell $fd;
185              
186 4         17 $datastash{$package}->{offset} = $position;
187              
188 4         9 return $position;
189             }
190              
191             sub _is_valid_data_tell {
192 28     28   81 my ( $self, $package ) = @_;
193 28 100 66     227 return 1
194             if ( exists $datastash{$package} && 1 == $datastash{$package}->{valid} );
195 5 100       17 if ( !$self->_has_data_symbol($package) ) {
196 1         3 _e('Internal::BadGet')->throw('_is_valid_data_tell was called when there is no data_symbol to get');
197             }
198              
199 4         18 my $fh = $self->_get_data_symbol($package);
200 4         20 my $offset = $self->_get_start_offset($package);
201              
202             # The offset to the start of __DATA__ is 9 bytes because it includes the
203             # trailing \n
204             #
205 4         8 my $checkfor = qq{__DATA__\n};
206 4         29 seek $fh, ( $offset - length $checkfor ), 0;
207 4         91 read $fh, my ($buffer), length $checkfor;
208 4         14 seek $fh, $offset, 0;
209              
210 4         13 $datastash{$package}->{previous_bytes} = $buffer;
211              
212 4 100       19 if ( $buffer eq $checkfor ) {
213 3         10 $datastash{$package}->{valid} = 1;
214 3         16 return 1;
215             }
216             else {
217 1         3 $datastash{$package}->{valid} = 0;
218 1         3 return;
219             }
220             }
221              
222             sub _stringify_metadata {
223 1     1   3 my ( undef, $package ) = @_;
224 1         3 my @lines = ();
225 1 50       3 if ( not exists $datastash{$package} ) {
226 0         0 push @lines, "Nothing known about $package\n";
227 0         0 return join "\n", @lines;
228             }
229             else {
230 1         3 push @lines, q{Offset : } . $datastash{$package}->{offset};
231 1         3 push @lines, q{Prelude : '} . $datastash{$package}->{previous_bytes} . q{'};
232 1         2 push @lines, q{Valid: } . $datastash{$package}->{valid};
233 1         16 return join "\n", @lines;
234             }
235             }
236              
237             sub _readline {
238 22     22   26 my ( $self, @args ) = @_;
239              
240 22 100       41 _e('API::Invalid::Params')->throw('_readline() takes no parameters') if @args;
241              
242 21         31 my $fh = $self->_fh;
243 21         32 $self->_restore_pos();
244 21 100       45 if (wantarray) {
245 1         8 my @result = <$fh>;
246 1         3 $self->_set_pos();
247 1         6 return @result;
248             }
249 20         111 my $result = <$fh>;
250 20         35 $self->_set_pos();
251 20         64 return $result;
252             }
253              
254             sub _read {
255 5     5   12 my ( $self, undef, $len, $offset ) = @_;
256              
257             ## no critic ( ProhibitMagicNumbers )
258 5 100 100     39 _e('API::Invalid::Params')->throw('_read() takes 2 or 3 parameters.')
259             if ( scalar @_ < 3 or scalar @_ > 4 );
260              
261 3         8 $self->_restore_pos();
262 3         4 my $return;
263 3 100       8 if ( defined $offset ) {
264 2         6 $return = read $self->_fh, $_[1], $len, $offset;
265             }
266             else {
267 1         2 $return = read $self->_fh, $_[1], $len;
268             }
269 3         8 $self->_set_pos();
270 3         7 return $return;
271             }
272              
273             sub _getc {
274 37     37   34 my ($self) = @_;
275 37 100       57 _e('API::Invalid::Params')->throw('_get() takes 0 parameters.')
276             if scalar @_ > 1;
277 36         40 $self->_restore_pos();
278 36         66 my $return = getc $self->_fh;
279 36         56 $self->_set_pos();
280 36         88 return $return;
281             }
282              
283             sub _seek {
284 8     8   12 my ( $self, $position, $whence ) = @_;
285              
286             ## no critic ( ProhibitMagicNumbers )
287              
288 8 100       54 _e('API::Invalid::Params')->throw('_seek() takes 2 params.')
289             if scalar @_ != 3;
290              
291 7         11 my $fh = $self->_stash->{filehandle};
292              
293 7 100       18 if ( 0 == $whence ) {
    50          
    50          
294 6         9 $position = $self->_stash->{start_offset} + $position;
295             }
296             elsif ( 1 == $whence ) {
297 0         0 $whence = 0;
298 0         0 $position = $self->_stash->{current_offset} + $position;
299             }
300             elsif ( 2 == $whence ) {
301             }
302             else {
303 1         3 _e('API::Invalid::Whence')->throw('Expected whence values are 0,1,2');
304             }
305 6         21 my $return = seek $fh, $position, $whence;
306 6         11 $self->_set_pos();
307 6         15 return $return;
308             }
309              
310             sub _tell {
311 3     3   4 my ($self) = shift;
312 3 100       11 _e('API::Invalid::Params')->throw('_tell() takes no params.') if @_;
313 2         4 return $self->_stash->{current_offset} - $self->_stash->{start_offset};
314             }
315              
316             sub _eof {
317 43     43   32 my $self = shift;
318 43 100 66     152 _e('API::Invalid::Params')->throw("_eof() takes no params : @_ ")
319             if @_ && $_[0] != 1;
320 42         49 $self->_restore_pos();
321 42         75 return eof $self->_stash->{filehandle};
322             }
323              
324             sub _restore_pos {
325 102     102   86 my $self = shift;
326 102         124 return seek $self->_stash->{filehandle}, $self->_stash->{current_offset}, 0;
327             }
328              
329             sub _set_pos {
330 66     66   59 my $self = shift;
331 66         66 return ( $self->_stash->{current_offset} = tell $self->_stash->{filehandle} );
332             }
333              
334 559     559   386 sub _stash { return ${ *{ $_[0] } }{stash} }
  559         330  
  559         1437  
335 1     1   3 sub _fileno { return }
336 25     25   267 sub _e { return 'Data::Handle::Exception::' . shift }
337 60     60   72 sub _fh { return shift->_stash->{filehandle} }
338              
339             sub _binmode {
340 2     2   6 return _e('API::NotImplemented')->throw('_binmode() is difficult on Data::Handle and not implemented yet.');
341             }
342              
343             sub _open {
344 2     2   16 return _e('API::Invalid')->throw('_open() is invalid on Data::Handle.');
345             }
346              
347             sub _close {
348 2     2   13 return _e('API::Invalid')->throw('_close() is invalid on Data::Handle');
349             }
350              
351             sub _printf {
352 2     2   13 return _e('API::Invalid')->throw('_printf() is invalid on Data::Handle.');
353             }
354              
355             sub _print {
356 2     2   10 return _e('API::Invalid')->throw('_print() is invalid on Data::Handle.');
357             }
358              
359             sub _write {
360 2     2   8 return _e('API::Invalid')->throw('_write() is invalid on Data::Handle.');
361             }
362              
363              
364              
365              
366              
367              
368              
369              
370              
371              
372              
373             1;
374              
375             __END__