File Coverage

blib/lib/Metabrik/File/Read.pm
Criterion Covered Total %
statement 9 193 4.6
branch 0 140 0.0
condition 0 10 0.0
subroutine 3 14 21.4
pod 2 11 18.1
total 14 368 3.8


line stmt bran cond sub pod time code
1             #
2             # $Id$
3             #
4             # file::read Brik
5             #
6             package Metabrik::File::Read;
7 1     1   837 use strict;
  1         2  
  1         28  
8 1     1   5 use warnings;
  1         1  
  1         27  
9              
10 1     1   5 use base qw(Metabrik);
  1         2  
  1         2225  
11              
12             sub brik_properties {
13             return {
14 0     0 1   revision => '$Revision$',
15             tags => [ qw(unstable) ],
16             author => 'GomoR ',
17             license => 'http://opensource.org/licenses/BSD-3-Clause',
18             attributes => {
19             input => [ qw(file) ],
20             encoding => [ qw(utf8|ascii) ],
21             fd => [ qw(file_descriptor) ],
22             as_array => [ qw(0|1) ],
23             eof => [ qw(0|1) ],
24             count => [ qw(count) ],
25             strip_crlf => [ qw(0|1) ],
26             skip_comment => [ qw(0|1) ],
27             skip_blank_line => [ qw(0|1) ],
28             },
29             attributes_default => {
30             as_array => 0,
31             eof => 0,
32             count => 1,
33             strip_crlf => 1,
34             skip_comment => 0,
35             skip_blank_line => 0,
36             },
37             commands => {
38             open => [ qw(file|OPTIONAL) ],
39             close => [ ],
40             offset => [ ],
41             seek => [ qw(offset) ],
42             read => [ ],
43             read_until_blank_line => [ ],
44             read_until_ini_block => [ ],
45             read_line => [ qw(count|OPTIONAL) ],
46             is_eof => [ ],
47             },
48             };
49             }
50              
51             sub brik_use_properties {
52 0     0 1   my $self = shift;
53              
54             return {
55 0   0       attributes_default => {
56             encoding => defined($self->global) && $self->global->encoding || 'utf8',
57             },
58             };
59             }
60              
61             sub open {
62 0     0 0   my $self = shift;
63 0           my ($input) = @_;
64              
65 0   0       $input ||= $self->input;
66 0 0         $self->brik_help_run_undef_arg('open', $input) or return;
67              
68 0           my $r;
69             my $out;
70 0   0       my $encoding = $self->encoding || 'ascii';
71 0 0         if ($encoding eq 'ascii') {
72 0           $r = open($out, '<', $input);
73             }
74             else {
75 0           $r = open($out, "<$encoding", $input);
76             }
77 0 0         if (! defined($r)) {
78 0           return $self->log->error("open: open: file [$input]: $!");
79             }
80              
81 0           return $self->fd($out);
82             }
83              
84             sub close {
85 0     0 0   my $self = shift;
86              
87 0 0         if (defined($self->fd)) {
88 0           close($self->fd);
89 0           $self->eof(0);
90             }
91              
92 0           return 1;
93             }
94              
95             sub offset {
96 0     0 0   my $self = shift;
97              
98 0           my $fd = $self->fd;
99 0 0         $self->brik_help_run_undef_arg('open', $fd) or return;
100              
101 0           my $r = CORE::tell($fd);
102 0 0         if (! defined($r)) {
103 0           return $self->log->error("offset: unable to get offset: [$!]");
104             }
105              
106 0           return $r;
107             }
108              
109             sub seek {
110 0     0 0   my $self = shift;
111 0           my ($offset) = @_;
112              
113 0           my $fd = $self->fd;
114 0 0         $self->brik_help_run_undef_arg('open', $fd) or return;
115 0 0         $self->brik_help_run_undef_arg('seek', $offset) or return;
116              
117 0           my $r = CORE::seek($fd, $offset, 0);
118 0 0         if (! $r) {
119 0           return $self->log->error("seek: unable to seek to offset [$offset]: [$!]");
120             }
121              
122 0           return $offset;
123             }
124              
125             sub read {
126 0     0 0   my $self = shift;
127              
128 0           my $fd = $self->fd;
129 0 0         $self->brik_help_run_undef_arg('open', $fd) or return;
130              
131 0           my $strip_crlf = $self->strip_crlf;
132 0           my $skip_comment = $self->skip_comment;
133 0           my $skip_blank_line = $self->skip_blank_line;
134              
135 0 0         if ($self->as_array) {
136 0           my @out = ();
137             # Don't play with $_, it may be tricky:
138             # https://www.perlmonks.org/bare/?node_id=570088
139 0           while (my $line = <$fd>) {
140 0 0         if ($skip_comment) {
141 0 0         next if $line =~ m{^\s*#};
142             }
143 0 0         if ($skip_blank_line) {
144 0 0         next if $line =~ m{^\s*$};
145             }
146 0 0         if ($strip_crlf) {
147 0           $line =~ s/[\r\n]*$//;
148             }
149 0           push @out, $line;
150             }
151 0           $self->eof(1);
152 0           return \@out;
153             }
154             else {
155 0           my $out = '';
156 0           while (my $line = <$fd>) {
157 0 0         if ($skip_comment) {
158 0 0         next if $line =~ m{^\s*#};
159             }
160 0 0         if ($skip_blank_line) {
161 0 0         next if $line =~ m{^\s*$};
162             }
163 0           $out .= $line;
164             }
165 0           $self->eof(1);
166 0 0         if ($strip_crlf) {
167 0           $out =~ s/[\r\n]*$//;
168             }
169 0           return $out;
170             }
171              
172 0           return;
173             }
174              
175             sub read_until_blank_line {
176 0     0 0   my $self = shift;
177              
178 0           my $fd = $self->fd;
179 0 0         $self->brik_help_run_undef_arg('open', $fd) or return;
180              
181 0           my $strip_crlf = $self->strip_crlf;
182 0           my $skip_comment = $self->skip_comment;
183              
184 0 0         if ($self->as_array) {
185 0           my @out = ();
186 0           while (my $line = <$fd>) {
187 0 0         if ($skip_comment) {
188 0 0         next if $line =~ m{^\s*#};
189             }
190 0 0         last if $line =~ /^\s*$/;
191 0 0         if ($strip_crlf) {
192 0           $line =~ s/[\r\n]*$//;
193             }
194 0           push @out, $line;
195             }
196 0 0         if (eof($fd)) {
197 0           $self->eof(1);
198             }
199 0           return \@out;
200             }
201             else {
202 0           my $out = '';
203 0           while (my $line = <$fd>) {
204 0 0         if ($skip_comment) {
205 0 0         next if $line =~ m{^\s*#};
206             }
207 0 0         last if $line =~ /^\s*$/;
208 0           $out .= $line;
209             }
210 0 0         if (eof($fd)) {
211 0           $self->eof(1);
212             }
213 0 0         if ($strip_crlf) {
214 0           $out =~ s/[\r\n]*$//;
215             }
216 0           return $out;
217             }
218              
219 0           return;
220             }
221              
222             sub read_until_ini_block {
223 0     0 0   my $self = shift;
224              
225 0           my $fd = $self->fd;
226 0 0         $self->brik_help_run_undef_arg('open', $fd) or return;
227              
228 0           my $strip_crlf = $self->strip_crlf;
229 0           my $skip_comment = $self->skip_comment;
230 0           my $skip_blank_line = $self->skip_blank_line;
231              
232 0           my $block = undef;
233 0           my $offset = 0;
234 0 0         if ($self->as_array) {
235 0           my @out = ();
236 0           while (my $line = <$fd>) {
237 0 0         if ($skip_comment) {
238 0 0         next if $line =~ m{^\s*#};
239             }
240 0 0         if ($skip_blank_line) {
241 0 0         next if $line =~ m{^\s*$};
242             }
243 0 0         if ($strip_crlf) {
244 0           $line =~ s/[\r\n]*$//;
245             }
246 0 0         if ($line =~ /^\s*\[\s*\S+\s*\]\s*$/) {
247 0 0         if (!defined($block)) {
248 0           $block = $line;
249             }
250             else {
251 0           $self->seek($offset); # New block starting, restore to previous offset
252             # for next Command call.
253 0           last;
254             }
255             }
256 0           push @out, $line;
257 0 0         $offset = $self->offset($fd) or return;
258             }
259 0 0         if (eof($fd)) {
260 0           $self->eof(1);
261             }
262 0           return \@out;
263             }
264             else {
265 0           my $out = '';
266 0           while (my $line = <$fd>) {
267 0 0         if ($skip_comment) {
268 0 0         next if $line =~ m{^\s*#};
269             }
270 0 0         if ($skip_blank_line) {
271 0 0         next if $line =~ m{^\s*$};
272             }
273 0 0         if ($line =~ /^\s*\[\s*\S+\s*\]\s*$/) {
274 0 0         if (!defined($block)) {
275 0           $block = $line;
276             }
277             else {
278 0           $self->seek($offset); # New block starting, restore to previous offset
279             # for next Command call.
280 0           last;
281             }
282             }
283 0           $out .= $line;
284 0 0         $offset = $self->offset($fd) or return;
285             }
286 0 0         if (eof($fd)) {
287 0           $self->eof(1);
288             }
289 0 0         if ($strip_crlf) {
290 0           $out =~ s/[\r\n]*$//;
291             }
292 0           return $out;
293             }
294              
295 0           return;
296             }
297              
298             sub read_line {
299 0     0 0   my $self = shift;
300 0           my ($count) = @_;
301              
302 0           my $fd = $self->fd;
303 0 0         $self->brik_help_run_undef_arg('open', $fd) or return;
304              
305 0   0       $count ||= $self->count;
306              
307 0           my $strip_crlf = $self->strip_crlf;
308 0           my $skip_comment = $self->skip_comment;
309 0           my $skip_blank_line = $self->skip_blank_line;
310              
311 0 0         if ($self->as_array) {
312 0           my @out = ();
313 0           my $this = 1;
314 0           while (my $line = <$fd>) {
315 0 0         if ($skip_comment) {
316 0 0         next if $line =~ m{^\s*#};
317             }
318 0 0         if ($skip_blank_line) {
319 0 0         next if $line =~ m{^\s*$};
320             }
321 0 0         if ($strip_crlf) {
322 0           $line =~ s/[\r\n]*$//;
323             }
324 0           push @out, $line;
325 0 0         last if $this == $count;
326 0           $count++;
327             }
328 0 0         if (eof($fd)) {
329 0           $self->eof(1);
330             }
331 0           return \@out;
332             }
333             else {
334 0           my $out = '';
335 0           my $this = 1;
336 0           while (my $line = <$fd>) {
337 0 0         if ($skip_comment) {
338 0 0         next if $line =~ m{^\s*#};
339             }
340 0 0         if ($skip_blank_line) {
341 0 0         next if $line =~ m{^\s*$};
342             }
343 0 0         last if $line =~ /^\s*$/;
344 0           $out .= $line;
345 0 0         last if $this == $count;
346 0           $count++;
347             }
348 0 0         if (eof($fd)) {
349 0           $self->eof(1);
350             }
351 0 0         if ($strip_crlf) {
352 0           $out =~ s/[\r\n]*$//;
353             }
354 0           return $out;
355             }
356              
357 0           return;
358             }
359              
360             sub is_eof {
361 0     0 0   my $self = shift;
362              
363 0           return $self->eof;
364             }
365              
366             1;
367              
368             __END__