File Coverage

blib/lib/Text/NumericData/App/txdrows.pm
Criterion Covered Total %
statement 54 63 85.7
branch 17 30 56.6
condition 12 18 66.6
subroutine 10 10 100.0
pod 0 5 0.0
total 93 126 73.8


line stmt bran cond sub pod time code
1             package Text::NumericData::App::txdrows;
2              
3 1     1   82728 use Text::NumericData;
  1         6  
  1         86  
4 1     1   454 use Text::NumericData::Calc qw(expression_function);
  1         3  
  1         56  
5 1     1   376 use Text::NumericData::App;
  1         3  
  1         30  
6              
7 1     1   5 use strict;
  1         22  
  1         605  
8              
9             # This is just a placeholder because of a past build system bug.
10             # The one and only version for Text::NumericData is kept in
11             # the Text::NumericData module itself.
12             our $VERSION = '1';
13             $VERSION = eval $VERSION;
14              
15             my $infostring = 'split a section of sets out of singe data file
16              
17             Usage:
18             pipe | txdrows -b=3 -e=10 | pipe
19             pipe | txdrows \'near([1], 3.1)\' | pipe
20              
21             This program extracs rows (data sets, sections, records, ...) of a numerical text file. Either this is a configured range of lines via begin/end indices or a decimation factor, or a set of rows matching a given expression on the command line.
22             The last example employs such an expression to match the first row that has a value near 3.1 in the first column. You could specify a third argument to near() to change the default allowed deviation. If you deal with integer values, using
23              
24             pipe | txdrows \'[1] == 3\' | pipe
25              
26             is fine, too, for selecting value 3.';
27              
28             our @ISA = ('Text::NumericData::App');
29              
30             sub new
31             {
32 1     1 0 117 my $class = shift;
33 1         14 my @pars =
34             (
35             'begin', 1, 'b',
36             'begin of section (above all other criteria)'
37             ,'end', -1, 'e',
38             'end of section (when negative: until end; above all other criteria)'
39             ,'reduce', '1', 'r',
40             'Redunce row count by a certain factor: Only include every ...th one. A value of 2 means rows 1,3,5... , a value of 10 means rows 1,11,21... (from the input).'
41             ,'justmatch',1,'j',
42             'if an expression to match is given, select what to print out: 0 means all matches including header, >0 means just the first n matches, <0 means all matches, but no header'
43             ,'verbose',0,'v',
44             'be verbose about things'
45             ,'ranges', [], 'R', 'give multiple ranges (format: "from:to", either may'
46             . ' be omitted or set to negative to extend to beginning/end) inside'
47             . ' the main range given by begin and end indices, this does not'
48             . ' duplicate or rearrange data, just specifies an additional condition'
49             . ' to include a record or not, in input order'
50             );
51              
52 1         25 return $class->SUPER::new
53             ({
54             parconf =>
55             {
56             info=>$infostring # default version
57             # default author
58             # default copyright
59             }
60             ,pardef => \@pars
61             ,pipemode => 1
62             ,pipe_init => \&preinit
63             ,pipe_begin => \&init
64             ,pipe_header => \&process_header
65             ,pipe_data => \&process_data
66             });
67             }
68              
69             sub preinit
70             {
71 4     4 0 15 my $self = shift;
72 4         14 my $p = $self->{param};
73              
74             # Sanitation...
75 4 50       26 $self->{reduce} = $p->{reduce} < 1 ? 1 : $p->{reduce};
76              
77 4         13 $self->{match} = shift(@{$self->{argv}});
  4         18  
78 4         52 $self->{matchfun} = undef;
79 4         14 $self->{matchnohead} = 0;
80 4 100       19 if(defined $self->{match})
81             {
82 3         24 $self->{matchfun} = expression_function($self->{match}, $p->{verbose});
83 3 50       18 return print STDERR "Error creating function for matching.\n" unless defined $self->{matchfun};
84 3         14 $self->{matchnohead} = $p->{justmatch} != 0;
85             }
86 4         16 $self->{ranges} = [];
87 4 50       14 if(@{$p->{ranges}})
  4         26  
88             {
89 0         0 for(@{$p->{ranges}})
  0         0  
90             {
91 0 0       0 return print STDERR "Bad range: $_\n"
92             unless /^\s*([+\-]?\d*)\s*:\s*([+\-]?\d*)\s*$/;
93 0 0       0 push(@{$self->{ranges}}, [$1 ne '' ? $1 : -1, $2 ne '' ? $2 : -1]);
  0 0       0  
94             }
95             }
96 4         20 return 0;
97             }
98              
99             sub init
100             {
101 4     4 0 508 my $self = shift;
102 4         40 $self->new_txd();
103 4         13 $self->{line} = 0;
104 4         15 $self->{matched} = 0;
105             }
106              
107             sub process_header
108             {
109 8     8 0 22 my $self = shift;
110 8 100       39 $_[0] = '' if $self->{matchnohead};
111             }
112              
113             # Check if given line index is inside the configured ranges,
114             # including reduction. Everything that works on the line index alone.
115             sub _chosen_line()
116             {
117 16     16   36 my $self = shift;
118 16         39 my $p = $self->{param};
119 16         39 my $i = shift;
120              
121             return 0 # Global range first.
122 16 100 100     98 unless($i >= $p->{begin} and ($p->{end} < 0 or $i <= $p->{end}));
      100        
123             return 0 # Line reduction, the other simple test.
124 14 50       64 unless(($self->{line}-1) % $self->{reduce} == 0);
125             # At last, the more elaborate check of sub-ranges.
126 14 50       31 if(@{$self->{ranges}})
  14         51  
127             {
128 0         0 for(@{$self->{ranges}})
  0         0  
129             {
130 0 0 0     0 return 1
      0        
131             if($i >= $_->[0] and ($_->[1] < 0 or $i <= $_->[1]));
132             }
133 0         0 return 0; # There are ranges, but none contain this index.
134             }
135             else
136             {
137 14         59 return 1; # No further sub-ranges. It's in.
138             }
139             }
140              
141             sub process_data
142             {
143 16     16 0 42 my $self = shift;
144 16         45 my $p = $self->{param};
145 16         43 ++$self->{line};
146             # Checks based on line number.
147 16 100       57 unless($self->_chosen_line($self->{line}))
148             {
149 2         6 $_[0] = '';
150 2         7 return;
151             }
152             # Additional check with match function.
153 14 100       51 if(defined $self->{matchfun})
154             {
155 12 100 100     130 if
      100        
156             (
157             not($p->{justmatch} > 0 and not $self->{matched} < $p->{justmatch})
158             and $self->{matchfun}->([$self->{txd}->line_data($_[0])])
159 4         16 ){ ++$self->{matched}; }
160 8         32 else{ $_[0] = ''; }
161             }
162             }
163              
164             1;