File Coverage

lib/BoutrosLab/TSVStream/IO/Role/Base/Fixed.pm
Criterion Covered Total %
statement 96 99 96.9
branch 17 24 70.8
condition 2 3 66.6
subroutine 21 23 91.3
pod n/a
total 136 149 91.2


line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             BoutrosLab::TSVStream:IO::Role::Base::Fixed
4              
5             =head1 SYNOPSIS
6              
7             This is a collection of base attributes and methods used internally
8             by TSVStream reader and writer role modules. It provides the
9             common parameters used to define reader and writer methods that
10             can be imported into a target class.
11              
12             =cut
13              
14             package BoutrosLab::TSVStream::IO::Role::Base::Fixed;
15              
16             # safe Perl
17 8     8   29 use warnings;
  8         9  
  8         207  
18 8     8   23 use strict;
  8         8  
  8         138  
19 8     8   23 use Carp;
  8         8  
  8         363  
20 8     8   29 use feature 'say';
  8         7  
  8         649  
21              
22 8     8   28 use Moose::Role;
  8         20  
  8         39  
23 8     8   27004 use namespace::autoclean;
  8         9  
  8         49  
24 8     8   416 use Try::Tiny;
  8         11  
  8         10223  
25              
26             # Base role for all reader/writer variants
27             #
28             # The BUILDARGS wrapper checks wheter a handle was proveded
29             # and, if not, opens the file provided and sets the handle
30             # to that newly opened fd.
31             #
32             # The class that consumes this role can add two extra entries
33             # to the arg list:
34             # - _open_mode - the mode to be used for an open (usually
35             # one of '<', '>', '>>')
36             # - _valid_arg - a hash of arg names to be validated, any
37             # arg key provided which does not match a
38             # key in this hash will cause an error
39             # (the _valid_arg and _open_mode args will not
40             # cause an error - they do not need to be
41             # listed in the _valid_arg hash since they
42             # are provided internally and removed before
43             # validation).
44              
45             has handle => ( is => 'ro', required => 1, isa => 'FileHandle' );
46              
47             has file => ( is => 'ro', lazy => 1, isa => 'Str', default => '[Unnamed stream]' );
48              
49             has class => ( is => 'ro', required => 1, isa => 'Str' );
50              
51             has [ qw(comment pre_comment pre_header) ] => ( is => 'ro', isa => 'Bool', default => 0 );
52              
53             has comment_pattern => (
54             is => 'ro',
55             isa => 'RegexpRef',
56             default => sub { qr/(?:^\s*#)|(?:^\s*$)/ }
57             );
58              
59             sub _null_header_fix {
60 88     88   189 return $_[0];
61             }
62              
63             has header_fix => (
64             is => 'ro',
65             isa => 'CodeRef',
66             default => sub { \&_null_header_fix }
67             );
68              
69             around BUILDARGS => sub {
70             my $orig = shift;
71             my $class = shift;
72             my $arg = ref($_[0]) ? $_[0] : { @_ };
73              
74             my $open_mode = delete $arg->{_open_mode} || '<';
75             if (my $valid_arg = delete $arg->{_valid_arg}) {
76             my @unknowns = grep { !$valid_arg->{$_} } keys %$arg;
77             if (@unknowns) {
78             my $s = 1 == scalar(@unknowns) ? '' : 's';
79             confess "Unknown option$s ("
80             . join( ',', @unknowns )
81             . "), valid options are ("
82             . join( ',', keys %$valid_arg )
83             . ")\n";
84             }
85             }
86              
87             unless ($arg->{handle}) {
88             if ($arg->{file}) {
89             open my $fh, $open_mode, $arg->{file}
90             or croak "unable to open $open_mode ", $arg->{file}, ": $!";
91             $arg->{handle} = $fh;
92             }
93             else {
94             croak "one of file/handle options must be provided";
95             }
96             }
97             $class->$orig( $arg );
98             };
99              
100             has fields => (
101             is => 'ro',
102             lazy => 1,
103             isa => 'ArrayRef[Str]',
104             builder => '_init_fields',
105             init_arg => undef
106             );
107              
108             sub _init_fields {
109 129     129   119 my $self = shift;
110 129         3821 $self->class->_fields
111             }
112              
113             has _num_fields => (
114             is => 'rw',
115             isa => 'Int',
116             init_arg => undef,
117             lazy => 1,
118             default => sub { my $self = shift; scalar( @{ $self->fields } ) }
119             );
120              
121             has _field_out_methods => (
122             is => 'ro',
123             lazy => 1,
124             isa => 'Ref',
125             builder => '_init_out_fields',
126             init_arg => undef
127             );
128              
129             sub _init_out_fields {
130 10     10   15 my $self = shift;
131             return [
132             map {
133 50         74 my $o_meth = "_${_}_out";
134 50 50       563 $self->can($o_meth) ? $o_meth : $_
135             }
136 10         12 @{ $self->class->_fields }
  10         335  
137             ];
138             }
139              
140             has _save_lines => (
141             is => 'rw',
142             isa => 'ArrayRef[Str]',
143             init_arg => undef,
144             default => sub { [] }
145             );
146              
147             has _at_eof => (
148             is => 'rw',
149             isa => 'Bool',
150             init_arg => undef,
151             default => undef
152             );
153              
154             has _is_comment => (
155             is => 'ro',
156             isa => 'CodeRef',
157             lazy => 1,
158             builder => '_init_is_comment'
159             );
160              
161             sub _init_is_comment {
162 2     2   6 my $self = shift;
163 2 50       57 if ($self->comment) {
164 2         63 my $pat = $self->comment_pattern;
165 12     12   64 sub { $_[0] =~ /$pat/ }
166 2         64 }
167             else {
168 0     0   0 sub { 0 };
  0         0  
169             }
170             }
171              
172             sub _read_config {
173 137     137   3568 return ();
174             }
175              
176             sub _peek {
177 465     465   384 my $self = shift;
178 465 50       13183 return if $self->_at_eof;
179 465         13573 my $lines = $self->_save_lines;
180 465 100       715 unless (@$lines) {
181 342         9403 my $h = $self->handle;
182 342         1088 my $line = <$h>;
183 342 100       511 if (not defined $line) {
184 106         3019 $self->_at_eof(1);
185 106         172 return;
186             }
187 236         314 chomp $line;
188 236         426 my $hash = { line => $line };
189 236         637 $line =~ s/^ *//;
190 236         830 $line =~ s/ *$//;
191 236         763 $hash->{fields} = [ split "\t", $line ];
192 236         406 push @$lines, $hash;
193             }
194 359         564 return $lines->[0];
195             }
196              
197             sub _read {
198 372     372   324 my $self = shift;
199 372 100       10795 return if $self->_at_eof;
200 346         490 my $line = $self->_peek;
201 346 100       775 return unless defined $line;
202 264 50       388 shift @{ $self->_save_lines } if defined $line;
  264         7656  
203 264         681 return $line;
204             }
205              
206             sub _unread {
207 28     28   26 my $self = shift;
208 28 50       48 if (@_) {
209 28         150 unshift @{ $self->_save_lines }, @_;
  28         823  
210 28         755 $self->_at_eof(0);
211             }
212             }
213              
214             sub _croak {
215 9     9   15 my $self = shift;
216 9         15 my $msg = shift;
217              
218 9         16 my $content = '';
219              
220 9 50       26 if (@_) {
221 9         13 my $vals = shift;
222             try {
223 9     9   684 my @flds = @{ $self->fields };
  9         332  
224 9 100 66     168 push @flds, @{ $self->dyn_fields } if $self->can('dyn_fields') && $self->_has_dyn_fields;
  3         81  
225 9         47 push @flds, '*extra*' while @flds < @$vals;
226 9         34 push @$vals, '*MISSING*' while @$vals < @flds;
227 9         14 $content = "\n --\> content:"; # --\> without the \ Perl::Critic thinks it is an arrow operator
228 9         21 while (@flds) {
229 54         43 my $f = shift @flds;
230 54         45 my $v = shift @$vals;
231 54         149 $content .= sprintf "\n --\> %s(%s)", $f, $v;
232             }
233             }
234             catch {
235 0     0   0 $content = "\n --\> Secondary failure trying to dump fields ($_)";
236             }
237 9         103 }
238              
239 9         476 my $pos = $self->handle->input_line_number;
240 9         13817 my $file = $self->file;
241 9         198 croak "Error: $msg\n --\> file: $file\n --\> line: $pos,$content\n";
242             }
243              
244             sub _write_fields {
245 29     29   31 my $self = shift;
246 29         943 my $h = $self->handle;
247 29         567 print $h join("\t", @_), "\n";
248             }
249              
250             sub _write_lines {
251 12     12   14 my $self = shift;
252 12         343 my $h = $self->handle;
253 12 50       20 my @lines = map { ref($_) ? @$_ : $_ } @_;
  12         40  
254 12         90 print $h "$_\n" for @lines;
255             }
256              
257             sub _to_fields {
258 24     24   23 my $self = shift;
259 24         21 my $obj = shift;
260 24         23 return map { $obj->$_ } @{ $self->_field_out_methods };
  120         3148  
  24         840  
261             }
262              
263             =head1 AUTHOR
264              
265             John Macdonald - Boutros Lab
266              
267             =head1 ACKNOWLEDGEMENTS
268              
269             Paul Boutros, Phd, PI - Boutros Lab
270              
271             The Ontario Institute for Cancer Research
272              
273             =cut
274              
275             1;
276