File Coverage

lib/File/ByLine/Object.pm
Criterion Covered Total %
statement 324 374 86.6
branch 167 218 76.6
condition 36 42 85.7
subroutine 40 41 97.5
pod 0 19 0.0
total 567 694 81.7


line stmt bran cond sub pod time code
1             #!/usr/bin/perl
2              
3             #
4             # Copyright (C) 2018 Joelle Maslak
5             # All Rights Reserved - See License
6             #
7              
8             package File::ByLine::Object;
9             $File::ByLine::Object::VERSION = '1.192590';
10 79     79   869 use v5.10;
  79         320  
11              
12             # ABSTRACT: Internal object used by File::ByLine
13              
14 79     79   380 use strict;
  79         83  
  79         1266  
15 79     79   305 use warnings;
  79         92  
  79         2010  
16 79     79   532 use autodie;
  79         154  
  79         331  
17              
18 79     79   353718 use Carp;
  79         156  
  79         3725  
19 79     79   396 use Fcntl;
  79         570  
  79         14172  
20 79     79   473 use Scalar::Util qw(blessed reftype);
  79         156  
  79         320355  
21              
22             # We do this intentionally:
23             ## no critic (Subroutines::ProhibitBuiltinHomonyms)
24              
25             # Attributes and their accessors & defaults, used by the constructor
26             # Each attribute name is the key of the hash, with the value being a
27             # hashref of two values: accessor and default value.
28             my (%ATTRIBUTE) = (
29             file => [ \&file, undef, ['f'] ],
30             extended_info => [ \&extended_info, undef, ['ei'] ],
31             header_all_files => [ \&header_all_files, undef, ['haf'] ],
32             header_handler => [ \&header_handler, undef, ['hh'] ],
33             header_skip => [ \&header_skip, undef, ['hs'] ],
34             processes => [ \&processes, 1, ['p'] ],
35             skip_unreadable => [ \&skip_unreadable, undef, ['su'] ],
36             );
37              
38              
39             #
40             # Attribute Accessor - file
41             #
42 4     4 0 12 sub f { goto &file }
43              
44             sub file {
45 35     35 0 2647 my ($self) = shift;
46 35 100       93 if ( scalar(@_) == 0 ) {
    100          
47 11         51 return $self->{file};
48             } elsif ( scalar(@_) == 1 ) {
49 23         33 my $file = shift;
50 23 100       53 if ( !defined($file) ) { confess("Must pass a file or array ref as a file attribute") }
  1         159  
51 22         62 return $self->{file} = $file;
52             } else {
53 1         7 return $self->{file} = [@_];
54             }
55             }
56              
57             #
58             # Attribute Accessor - extended_info
59             #
60             # Do we pass an extended information hash to the user process?
61 4     4 0 9 sub ei { goto &extended_info }
62              
63             sub extended_info {
64 69     69 0 1351 my ($self) = shift;
65 69 100       967 if ( scalar(@_) == 0 ) {
    50          
66 11         44 return $self->{extended_info};
67             } elsif ( scalar(@_) == 1 ) {
68 58         584 return $self->{extended_info} = !!$_[0]; # !! to convert to fast boolean
69             } else {
70 0         0 confess("Invalid call");
71             }
72             }
73              
74             #
75             # Attribute Accessor - processes
76             #
77             # This is the degree of parallism we will attempt for most methods (the
78             # exception is "lines()")
79 3     3 0 427 sub p { goto &processes }
80              
81             sub processes {
82 781     781 0 27531 my ($self) = shift;
83 781 100       3136 if ( scalar(@_) == 0 ) {
    100          
84 75         231 return $self->{processes};
85             } elsif ( scalar(@_) == 1 ) {
86 705         1379 my $procs = shift;
87              
88 705 100       3200 if ( !_is_number($procs) ) {
89 124         14188 confess("processes only accepts integer values");
90             }
91              
92 581 100       2546 if ( $procs < 1 ) {
93 1         75 confess("Process count must be >= 1");
94             }
95 580 100       1606 if ( $procs > 1 ) {
96             # Ensure we have the right packages installed
97 506         2146 $self->_require_parallel();
98             }
99 580         2301 return $self->{processes} = $procs;
100             } else {
101 1         73 confess("Invalid call");
102             }
103             }
104              
105             #
106             # Attribute Accessor - header_all_files
107             #
108             # If set to one, process all files for headers
109 5     5 0 14 sub haf { goto &header_all_files }
110              
111             sub header_all_files {
112 66     66 0 370 my ($self) = shift;
113 66 100       233 if ( scalar(@_) == 0 ) {
    50          
114 59         678 return $self->{header_all_files};
115             } elsif ( scalar(@_) == 1 ) {
116 7         20 return $self->{header_all_files} = $_[0];
117             } else {
118 0         0 confess("Invalid call");
119             }
120             }
121              
122             #
123             # Attribute Accessor - header_handler
124             #
125             # This is the code that handles the header line
126 4     4 0 13 sub hh { goto &header_handler }
127              
128             sub header_handler {
129 505     505 0 8634 my ($self) = shift;
130 505 100       1586 if ( scalar(@_) == 0 ) {
    50          
131 392         1864 return $self->{header_handler};
132             } elsif ( scalar(@_) == 1 ) {
133 113         465 my $code = shift;
134 113 100       851 if ( defined($code) ) {
135 110 100       1082 if ( !_codelike($code) ) {
136 3         354 confess("header_handler must be a code reference");
137             }
138 107 50       910 if ( $self->{header_skip} ) {
139 0         0 confess("Must unset header_skip before setting a header_handler");
140             }
141             }
142 110         763 return $self->{header_handler} = $code;
143             } else {
144 0         0 confess("Invalid call");
145             }
146             }
147              
148             #
149             # Attribute Accessor - header_skip
150             #
151             # If set to one, skip the header line
152 4     4 0 11 sub hs { goto &header_skip }
153              
154             sub header_skip {
155 326     326 0 1250 my ($self) = shift;
156 326 100       1514 if ( scalar(@_) == 0 ) {
    50          
157 276         2488 return $self->{header_skip};
158             } elsif ( scalar(@_) == 1 ) {
159 50 50 66     862 if ( $_[0] && $self->{header_handler} ) {
160 0         0 confess("Must undefine header_handler before setting header_skip");
161             }
162 50         273 return $self->{header_skip} = $_[0];
163             } else {
164 0         0 confess("Invalid call");
165             }
166             }
167              
168             #
169             # Attribute Accessor - skip_unreadable
170             #
171 5     5 0 13 sub su { goto &skip_unreadable; }
172              
173             sub skip_unreadable {
174 19     19 0 239 my ($self) = shift;
175 19 100       52 if ( scalar(@_) == 0 ) {
    50          
176 12         40 return $self->{skip_unreadable};
177             } elsif ( scalar(@_) == 1 ) {
178 7         24 return $self->{skip_unreadable} = !!$_[0]; # !! to convert to fast boolean
179             } else {
180 0         0 confess("Invalid call");
181             }
182             }
183              
184             #
185             # Constructor
186             #
187             sub new {
188 814     814 0 5113 my $class = shift;
189              
190 814         3384 my %options;
191 814 100       11839 if ( scalar(@_) == 1 ) {
    100          
192             # We assume this to be a hashref of options
193 3         4 %options = %{ $_[0] };
  3         11  
194             } elsif ( scalar(@_) > 1 ) {
195 3 100       9 if ( scalar(@_) % 2 ) {
196 1         165 confess("Must pass options in key/value form or as a hashref");
197             } else {
198 2         6 %options = (@_);
199             }
200             }
201              
202             # Set defaults
203 813         2117 my $self = {};
204 813         10317 foreach my $attr ( keys %ATTRIBUTE ) {
205 5691         14844 $self->{$attr} = $ATTRIBUTE{$attr}->[1]; # Default avlue
206             }
207              
208 813         2462 bless $self, $class;
209              
210             # Build abbreviation list
211 813         3587 my (%attr_short);
212 813         2843 foreach my $attr ( keys %ATTRIBUTE ) {
213 5691         11598 foreach my $abbr ( @{ $ATTRIBUTE{$attr}->[2] } ) {
  5691         18861  
214 5691         26444 $attr_short{$abbr} = $attr; # Default avlue
215             }
216             }
217              
218             # Set attributes. We use the accessor so we don't duplicate type
219             # checks.
220 813         3766 my %set; # Track set attributes
221 813         5338 foreach my $key ( sort keys %options ) { # Sort for consistent tests
222 22 100       38 if ( exists( $ATTRIBUTE{$key} ) ) {
    100          
223 13 50       21 if ( exists( $set{$key} ) ) {
224 0         0 confess("Duplicate attribute in constructor detected: $key");
225             }
226              
227 13         15 my $value = $options{$key};
228              
229             # Call the accessor
230 13         25 $ATTRIBUTE{$key}->[0]( $self, $value );
231 13         18 $set{$key} = 1; # Mark as set
232             } elsif ( exists( $attr_short{$key} ) ) {
233 7         8 my $cannonical = $attr_short{$key};
234              
235 7 50       13 if ( exists( $set{$key} ) ) {
236 0         0 confess("Duplicate attribute in constructor detected: $key");
237             }
238              
239 7         9 my $value = $options{$key};
240              
241             # Call the accessor
242 7         12 $ATTRIBUTE{$cannonical}->[0]( $self, $value );
243 7         13 $set{$key} = 1; # Mark as set
244             } else {
245 2         341 confess("Invalid attribute: $key");
246             }
247             }
248              
249 811         5277 return $self;
250             }
251              
252             #
253             # Method - do
254             #
255             # Executes the provided code on every line.
256             #
257             sub do {
258 409 50   409 0 3495 if ( scalar(@_) < 2 ) { confess "Invalid call"; }
  0         0  
259 409         1972 my ( $self, $code, $file ) = @_;
260              
261 409 100       1432 if ( !defined($file) ) { $file = $self->{file} }
  3         9  
262 409 50       972 if ( !defined($file) ) { confess "Must provide filename"; }
  0         0  
263 409 100       2244 if ( !_listlike($file) ) { $file = [$file] }
  308         712  
264              
265 409 100       1591 if ( defined( $self->{header_handler} ) ) {
266 98         393 my $fileno = 0;
267 98         295 for my $f (@$file) {
268 145         1010 $self->_read_header( $f, $fileno );
269 145         385 $fileno++;
270             }
271             }
272              
273 409 100       1310 if ( $self->{processes} == 1 ) {
274 22         68 return $self->_forlines_chunk( $code, $file, 0 );
275             } else {
276 387         3435 my $wu = Parallel::WorkUnit->new();
277             $wu->asyncs( $self->{processes},
278 387     42   23487 sub { return $self->_forlines_chunk( $code, $file, $_[0] ); } );
  42         400416  
279 345         2611406 my (@linecounts) = $wu->waitall();
280              
281 345         244574679 my $total_lines = 0;
282 345         1781 foreach my $cnt (@linecounts) {
283 1386         3472 $total_lines += $cnt;
284             }
285              
286 345         6820 return $total_lines;
287             }
288             }
289              
290             #
291             # Method - grep
292             #
293             # Finds and returns matching lines
294             sub grep {
295 74 50   74 0 314 if ( scalar(@_) < 2 ) { confess "Invalid call, too few arguments"; }
  0         0  
296 74 50       304 if ( scalar(@_) > 3 ) { confess "Invalid call, too many arguments"; }
  0         0  
297 74         200 my ( $self, $code, $file ) = @_;
298              
299 74         767 return $self->_grepmap( 'grep', $code, $file );
300             }
301              
302             #
303             # Method - map
304             #
305             # Applies function to each entry and returns that result
306             sub map {
307 115 50   115 0 648 if ( scalar(@_) < 2 ) { confess "Invalid call, too few arguments"; }
  0         0  
308 115 50       402 if ( scalar(@_) > 3 ) { confess "Invalid call, too many arguments"; }
  0         0  
309 115         427 my ( $self, $code, $file ) = @_;
310              
311 115         574 return $self->_grepmap( 'map', $code, $file );
312             }
313              
314             # Does the actual processing for map/grep
315             sub _grepmap {
316 189 50   189   492 if ( scalar(@_) < 3 ) { confess "Invalid call, too few arguments"; }
  0         0  
317 189 50       636 if ( scalar(@_) > 4 ) { confess "Invalid call, too many arguments"; }
  0         0  
318 189         505 my ( $self, $type, $code, $file ) = @_;
319              
320 189 100       562 if ( !defined($file) ) { $file = $self->{file} }
  2         5  
321 189 50       492 if ( !defined($file) ) { confess "Must provide filename"; }
  0         0  
322 189 100       1062 if ( !_listlike($file) ) { $file = [$file] }
  142         469  
323              
324 189 100       674 if ( defined( $self->{header_handler} ) ) {
325 4         6 my $fileno = 0;
326 4         9 for my $f (@$file) {
327 4         12 $self->_read_header( $f, $fileno );
328 4         8 $fileno++;
329             }
330             }
331              
332 189         363 my $procs = $self->{processes};
333              
334             # Is this a MAP or a GREP?
335 189         251 my $isgrep;
336 189 100       918 if ( $type eq 'grep' ) {
    50          
337 74         218 $isgrep = 1;
338             } elsif ( $type eq 'map' ) {
339 115         226 $isgrep = 0;
340             } else {
341 0         0 confess("Invalid type passed to _grepmap: $type");
342             }
343              
344 189 100       590 if ( $procs > 1 ) {
345 119         1003 my $wu = Parallel::WorkUnit->new();
346              
347             $wu->asyncs( $procs,
348 119     28   6646 sub { return $self->_grepmap_chunk( $code, $file, $isgrep, $procs, $_[0] ); } );
  28         236136  
349              
350 91         601496 my @async_output = $wu->waitall();
351              
352 91         58439436 my @file_output;
353 91         817 for ( my $i = 0; $i < scalar(@$file); $i++ ) {
354 117         843 push @file_output, map { $_->[$i] } @async_output;
  468         1316  
355             }
356 91         259 return map { @$_ } @file_output;
  468         4121  
357             } else {
358 70         327 my $mapped_lines = $self->_grepmap_chunk( $code, $file, $isgrep, 1, 0 );
359              
360 70         170 return map { @$_ } @$mapped_lines;
  83         849  
361             }
362              
363             }
364              
365             #
366             # Method - lines
367             #
368             # Returns all lines in the file
369             sub lines {
370 21 50   21 0 129 if ( scalar(@_) < 1 ) { confess "Invalid call"; }
  0         0  
371 21         75 my ( $self, $file ) = @_;
372              
373 21 100       97 if ( !defined($file) ) { $file = $self->{file} }
  5         8  
374 21 50       68 if ( !defined($file) ) { confess "Must provide filename"; }
  0         0  
375 21 100       120 if ( !_listlike($file) ) { $file = [$file] }
  19         43  
376              
377 21         36 my @lines;
378 21         48 my $fileno = 0;
379 21         40 my $lineno = 0;
380              
381 21         74 for my $f (@$file) {
382 24         170 $fileno++;
383              
384 24         102 my $fh = $self->_open($f);
385 24 100       90 if ( !defined($fh) ) { next; } # Next file
  1         2  
386              
387 23         482 while (<$fh>) {
388 1002         1226 $lineno++;
389 1002         1403 chomp;
390              
391 1002 100       1572 if ( $lineno == 1 ) {
392 21 100       142 if ( $self->_handle_header( $f, $_, 0, $fileno - 1 ) ) {
393 4         19 next;
394             }
395             }
396              
397 998         2813 push @lines, $_;
398             }
399              
400 23         122 close $fh;
401             }
402              
403 21         3378 return @lines;
404             }
405              
406             # Internal function to read header line (if we need to)
407             sub _read_header {
408 149     149   535 my ( $self, $file, $fileno ) = @_;
409              
410 149         791 my ( $fh, undef ) = $self->_open_and_seek( $file, 1, 0 );
411 149 50       447 if ( !defined($fh) ) { return; }
  0         0  
412 149         3096 my $line = <$fh>;
413 149         958 close $fh;
414              
415 149 50       57484 if ( defined($line) ) {
416 149         504 chomp($line);
417 149         694 $self->_handle_header( $file, $line, 0, $fileno );
418             }
419              
420 149         591 return $line;
421             }
422              
423             # Internal function to perform a for loop on a single chunk of the file.
424             #
425             # Procs should be >= 1. It represents the number of chunks the file
426             # has.
427             #
428             # Part should be >= 0 and < Procs. It represents the zero-indexed chunk
429             # number this invocation is processing.
430             sub _forlines_chunk {
431 64     64   809 my ( $self, $code, $file, $part ) = @_;
432              
433 64         491 my $fileno = 0;
434 64         414 my $lineno = 0;
435 64         384 my $extended_info = $self->{extended_info};
436              
437 64         625 for my $f (@$file) {
438 70         766 $fileno++;
439              
440 70         1168 my $extended = $self->_extended( $f, $part );
441              
442 70         438 my $procs = $self->{processes};
443 70         759 my ( $fh, $end ) = $self->_open_and_seek( $f, $procs, $part );
444 70 50       406 if ( !defined($fh) ) { next; } # Next file
  0         0  
445              
446 70         1836 while (<$fh>) {
447 72         518 $lineno++;
448              
449 72         311 chomp;
450              
451 72 100 100     1176 if ( $lineno == 1 && $self->_handle_header( $f, $_, $part, $fileno - 1 ) ) {
452             # Do nothing, we handled the header.
453             } else {
454 64 100       325 if ($extended_info) {
455 19         183 $code->( $_, $extended );
456             } else {
457 45         302 $code->($_);
458             }
459             }
460              
461             # If we're reading multi-parts, do we need to end the read?
462 72 100 66     29899 if ( ( $end > 0 ) && ( tell($fh) > $end ) ) { last; }
  25         104  
463             }
464              
465 70         632 close $fh;
466             }
467              
468 64         24500 return $lineno;
469             }
470              
471             # Internal function to perform a map/grep on a single chunk of the file.
472             #
473             # Procs should be >= 1. It represents the number of chunks the file
474             # has.
475             #
476             # Part should be >= 0 and < Procs. It represents the zero-indexed chunk
477             # number this invocation is processing.
478             #
479             # isgrep = true if we want to just apply the code as a grep, not as a
480             # map.
481             sub _grepmap_chunk {
482 98     98   597 my ( $self, $code, $file, $isgrep, $procs, $part ) = @_;
483              
484 98         286 my @mapped_lines;
485 98         187 my $fileno = 0;
486 98         177 my $lineno = 0;
487 98         256 my $extended_info = $self->{extended_info};
488              
489 98         672 for my $f (@$file) {
490 119         1558 $fileno++;
491              
492 119         889 my $extended = $self->_extended( $f, $part );
493              
494 119         581 my ( $fh, $end ) = $self->_open_and_seek( $f, $procs, $part );
495 119 50       390 if ( !defined($fh) ) { push @mapped_lines, []; next; }
  0         0  
  0         0  
496             ; # Go to next loop
497              
498 119         353 my @filelines;
499 119         2305 while (<$fh>) {
500 592         1197 $lineno++;
501              
502 592         1122 chomp;
503              
504 592 100 100     3204 if ( $lineno == 1 && $self->_handle_header( $f, $_, $part, $fileno - 1 ) ) {
    50 100        
      100        
      66        
505             # Do nothing, we handled the header.
506             } elsif ( ( !$part )
507             && ( $fileno == 1 )
508             && ( $lineno == 1 )
509             && ( $self->{header_skip} ) )
510             {
511             # Do nothing, we're skipping the header.
512             } else {
513 586 100       1252 if ($isgrep) {
514 311 100       504 if ($extended_info) {
515 3 100       8 if ( $code->( $_, $extended ) ) {
516 2         1132 push @filelines, $_;
517             }
518             } else {
519 308 100       671 if ( $code->($_) ) {
520 258         9780 push @filelines, $_;
521             }
522             }
523             } else {
524             # We are doing a map
525 275 100       613 if ($extended_info) {
526 3         8 push @filelines, $code->( $_, $extended );
527             } else {
528 272         555 push @filelines, $code->($_);
529             }
530             }
531             }
532              
533             # If we're reading multi-parts, do we need to end the read?
534 592 100 100     26535 if ( ( $end > 0 ) && ( tell($fh) > $end ) ) { last; }
  27         388  
535             }
536 119         712 push @mapped_lines, \@filelines;
537              
538 119         672 close $fh;
539             }
540              
541 98         7156 return \@mapped_lines;
542             }
543              
544             # Internal function to facilitate reading a file in chunks.
545             #
546             # If parts == 1, this basically just opens the file (and returns -1 for
547             # end, to be discussed later)
548             #
549             # If parts > 1, then this divides the file (by byte count) into that
550             # many parts, and then seeks to the first character at the start of a
551             # new line in that part (lines are attributed to the part in which they
552             # end).
553             #
554             # It also returns an end position - no line starting *after* the end
555             # position is in the relevant chunk.
556             #
557             # part_number is zero indexed.
558             #
559             # For part_number >= 1, the first valid character is actually start + 1
560             # If a line actually starts at the first position, we treat it as
561             # part of the previous chunk.
562             #
563             # If no lines would start in a given chunk, this seeks to the end of the
564             # file (so it gives an EOF on the first read)
565             sub _open_and_seek {
566 338 50   338   1320 if ( scalar(@_) != 4 ) { confess 'invalid call' }
  0         0  
567 338         1151 my ( $self, $file, $parts, $part_number ) = @_;
568              
569 338 50       2310 if ( !defined($parts) ) { $parts = 1; }
  0         0  
570 338 50       1537 if ( !defined($part_number) ) { $part_number = 0; }
  0         0  
571              
572 338 50       1277 if ( $parts <= $part_number ) {
573 0         0 confess("Part Number must be less than number of parts");
574             }
575 338 50       979 if ( $parts <= 0 ) {
576 0         0 confess("Number of parts must be > 0");
577             }
578 338 50       998 if ( $part_number < 0 ) {
579 0         0 confess("Part Number must be greater or equal to 0");
580             }
581              
582 338         3105 my $fh = $self->_open($file);
583 338 50       1172 if ( !defined($fh) ) { return ( $fh, 0 ); }
  0         0  
584              
585             # If this is a single part request, we are done here.
586             # We use -1, not size, because it's possible the read is from a
587             # terminal or pipe or something else that can grow.
588 338 50       4479 if ( $parts == 0 ) {
589 0         0 return ( $fh, -1 );
590             }
591              
592             # This is a request for part of a multi-part document. How big is
593             # it?
594 338         4398 seek( $fh, 0, Fcntl::SEEK_END );
595 338         63832 my $size = tell($fh);
596              
597             # Special case - more threads than needed.
598 338 100       1307 if ( $parts > $size ) {
599 21 100       57 if ( $part_number > $size ) { return ( $fh, -1 ) }
  9         94  
600              
601             # We want each part to be one byte, basically. Not fractiosn of
602             # a byte.
603 12         35 $parts = $size;
604             }
605              
606             # We have a zero byte file, special case
607 329 100       2601 if ( $parts == 0 ) {
608 12         47 return ( $fh, -1 );
609             }
610              
611             # Figure out start and end size
612 317         1891 my $start = int( $part_number * ( $size / $parts ) );
613 317         804 my $end = int( $start + ( $size / $parts ) );
614              
615             # Seek to start position
616 317         1335 seek( $fh, $start, Fcntl::SEEK_SET );
617              
618             # Read and discard junk to the end of line.
619             # But ONLY for parts other than the first one. We basically assume
620             # all parts > 1 are starting mid-line.
621 317 100       16119 if ( $part_number > 0 ) {
622 54         2235 scalar(<$fh>);
623             }
624              
625             # Special case - allow file to have grown since first read to end
626 317 100       1533 if ( ( $parts - 1 ) == $part_number ) {
627 263         1074 return ( $fh, -1 );
628             }
629              
630             # Another special case... If we're already past the end, seek to
631             # the end.
632 54 100       702 if ( tell($fh) > $end ) {
633 2         9 seek( $fh, 0, Fcntl::SEEK_END );
634             }
635              
636             # We return the file at this position.
637 54         435 return ( $fh, $end );
638             }
639              
640             sub _open {
641 362 50   362   1113 if ( scalar(@_) != 2 ) { confess 'invalid call'; }
  0         0  
642 362         1641 my ( $self, $file ) = @_;
643              
644 362 100 66     12827 if ( ( !-r $file ) && $self->{skip_unreadable} ) {
    50          
    50          
645 1         4 return; # We don't give an error if skip_unreadable
646             } elsif ( !-e _ ) { # _ is file handle from last stat() call
647 0         0 confess("File does not exist: $file");
648             } elsif ( !-r _ ) {
649 0         0 confess("File is unreadable: $file");
650             }
651 361 50       4805 open my $fh, '<', $file or die $!;
652              
653 361         227191 return $fh;
654             }
655              
656             sub _require_parallel {
657 506 50   506   1818 if ( scalar(@_) != 1 ) { confess 'invalid call'; }
  0         0  
658 506         1380 my $self = shift;
659              
660             require Parallel::WorkUnit
661 506 50       7465 or die("You must install Parallel::WorkUnit to use the parallel_* methods");
662              
663 506 50       1932 if ( $Parallel::WorkUnit::VERSION < 2.181850 ) {
664 0         0 die( "Parallel::WorkUnit version 2.181850 or newer required. You have "
665             . $Parallel::WorkUnit::Version );
666             }
667              
668 506         1100 return;
669             }
670              
671             # Validate something is code like
672             #
673             # Borrowed/modified from Params::Util (written by Adam Kennedy)
674             sub _codelike {
675 110 50   110   659 if ( scalar(@_) != 1 ) { confess 'invalid call' }
  0         0  
676 110         462 my $thing = shift;
677              
678 110 100 100     2592 if ( defined( reftype($thing) ) && ( reftype($thing) eq 'CODE' ) ) { return 1; }
  106         946  
679 4 100 100     18 if ( blessed($thing) && overload::Method( $thing, '&{}' ) ) { return 1; }
  1         56  
680              
681 3         51 return;
682             }
683              
684             sub _listlike {
685 619 50   619   2408 if ( scalar(@_) != 1 ) { confess 'invalid call' }
  0         0  
686 619         1277 my $thing = shift;
687              
688 619 100       3192 if ( reftype($thing) ) { return 1; }
  150         620  
689 469 50 33     1946 if ( defined( blessed($thing) ) && overload::Method( $thing, '[]' ) ) { return 1; }
  0         0  
690              
691 469         1407 return;
692             }
693              
694             # Takes a hashref, key, and default value
695             # If the hashref item exists, returns the corresponding value. If the hashref
696             # item does not exist, returns the default value.
697             sub _option_helper {
698 0 0   0   0 if ( scalar(@_) != 3 ) { confess 'invalid call' }
  0         0  
699 0         0 my ( $hash, $key, $default ) = @_;
700              
701 0 0       0 if ( exists( $hash->{$key} ) ) {
702 0         0 return $hash->{$key};
703             } else {
704 0         0 return $default;
705             }
706             }
707              
708             sub _is_number {
709 705 50   705   2407 if ( scalar(@_) != 1 ) { confess 'invalid call' }
  0         0  
710 705         1477 my $val = shift;
711              
712 705 100       1855 if ( !defined($val) ) { return; }
  1         3  
713              
714 704         8803 return $val =~ /
715             \A # Start of string
716             [0-9]+ # ASCII digit
717             (?: \. 0+)? # Optional .0 or .000 or .00000 etc
718             \z # End of string
719             /sx;
720             }
721              
722             # Returns an extended info object
723             sub _extended {
724 248 50   248   1531 if ( scalar(@_) != 3 ) { confess 'invalid call' }
  0         0  
725 248         1897 my ( $self, $filename, $process_number ) = @_;
726              
727             return {
728 248         3649 filename => $filename,
729             object => $self,
730             process_number => $process_number,
731             };
732             }
733              
734             # Executes the header_handler function when required, or skipps headers.
735             #
736             # This returns TRUE if there is a header to process. FALSE otherwise
737             #
738             # This takes several parameters:
739             # $self - This is an object method of course.
740             # $filename = The filename being processed
741             # $line - The line to process
742             # $part - Which "part" is calling this (we always return FALSE and
743             # refuse to process the header if $part > 0)
744             # $fileno - Which file number are we on (start at zero)
745             #
746             # If header_skip is FALSE and header_handler is unset, this ALWAYS
747             # returns false.
748             #
749             # This should never be called except for the first line of a file
750             sub _handle_header {
751 301 50   301   1125 if ( scalar(@_) != 5 ) { confess 'invalid call' }
  0         0  
752 301         1771 my ( $self, $filename, $line, $part, $fileno ) = @_;
753              
754 301 100       1084 if ($part) { return; }
  35         426  
755              
756 266 100 100     1052 if ( ( !$self->header_skip() ) && ( !defined( $self->header_handler() ) ) ) {
757 99         1706 return;
758             }
759              
760 167 100 100     945 if ( $fileno && ( !$self->header_all_files() ) ) {
761 46         182 return;
762             }
763              
764             # We have a header to process.
765 121 100       331 if ( defined( $self->header_handler() ) ) {
766 116         382 local $_ = $line;
767              
768 116 100       444 if ( $self->{extended_info} ) {
769 59         710 my $extended = $self->_extended( $filename, $part );
770 59         496 $self->{header_handler}( $line, $extended );
771             } else {
772 57         223 $self->{header_handler}($line);
773             }
774             }
775 121         8716 return 1;
776             }
777              
778              
779             1;
780              
781             __END__