File Coverage

blib/lib/Text/NumericData/App/txdcolumns.pm
Criterion Covered Total %
statement 61 70 87.1
branch 16 28 57.1
condition 4 9 44.4
subroutine 8 8 100.0
pod 0 6 0.0
total 89 121 73.5


line stmt bran cond sub pod time code
1             package Text::NumericData::App::txdcolumns;
2              
3 1     1   69983 use Text::NumericData::App;
  1         2  
  1         43  
4              
5 1     1   7 use strict;
  1         2  
  1         1057  
6              
7             # This is just a placeholder because of a past build system bug.
8             # The one and only version for Text::NumericData is kept in
9             # the Text::NumericData module itself.
10             our $VERSION = '1';
11             $VERSION = eval $VERSION;
12              
13             my $infostring = 'get specific columns out of textual data files
14              
15             Usage:
16             pipe | txdcolumns 3 1 | pipe
17              
18             to extract the third and the first (in that order) column of input. Guess how to extract columns 2, 4 and 3;-)';
19              
20             our @ISA = ('Text::NumericData::App');
21              
22             sub new
23             {
24 1     1 0 93 my $class = shift;
25 1         8 my @pars =
26             (
27             'columns',undef,'c'
28             , 'list (comma-separeted) of columns to extract - plain command line args are added to this list'
29             . ' (fully specified ranges are supported, 3-5 = 3,4,5)'
30             , 'title','-1','',
31             'choices for determining column indices from column titles: -1 for automatic treatment of given column values as plain indices if they are integers and as column title to match otherwise, 0: only expect numeric column indices, 1: only expect titles to match; about title matches: you give Perl regular expressions to match against the titles, you write the $bla part in m/$bla/'
32             , 'debug', 0, '', 'print some stuff to stderr to help debugging'
33             , 'invert', 0, 'i', 'specify columns to _omit_, not to include'
34             );
35              
36 1         19 return $class->SUPER::new
37             ({
38             parconf =>
39             {
40             info=>$infostring # default version
41             # default author
42             # default copyright
43             }
44             ,pardef => \@pars
45             ,pipemode => 1
46             ,pipe_init => \&preinit
47             ,pipe_begin => \&init
48             ,pipe_header => \&process_header
49             ,pipe_first_data => \&process_first_data
50             ,pipe_data => \&process_data
51             });
52             }
53              
54             sub preinit
55             {
56 3     3 0 6 my $self = shift;
57 3         5 my $param = $self->{param};
58              
59 3         9 $self->{pcols} = [];
60             my @pcols = defined $param->{columns}
61 3 100       11 ? (split(/\s*,\s*/, $param->{columns}))
62             : ();
63 3         7 for(@pcols, @{$self->{argv}})
  3         10  
64             {
65 7 50       16 if(/^(\d+)-(\d+)$/)
66             {
67 0 0       0 my $incr = $1 < $2 ? +1 : -1;
68 0         0 for(my $c = $1; $c != $2+$incr; $c+=$incr)
69             {
70 0         0 push(@{$self->{pcols}}, $c);
  0         0  
71             }
72             }
73             else
74             {
75 7         11 push(@{$self->{pcols}}, $_);
  7         15  
76             }
77             }
78             #print STDERR "You really want NO data?\n" unless @pcols;
79 3         7 return 0;
80             }
81              
82             sub init
83             {
84 3     3 0 302 my $self = shift;
85              
86 3         18 $self->new_txd();
87 3         9 $self->{cols} = [];
88 3         11 $self->{sline} = '';
89             }
90              
91             # Delay header printout for processing column headers.
92             sub process_header
93             {
94 6     6 0 13 my $self = shift;
95 6         10 my $sline = $_[0];
96 6         10 $_[0] = $self->{sline};
97 6         13 $self->{sline} = $sline;
98             }
99              
100             # This is the ugly part, deriving the columns and column headers to use.
101             sub process_first_data
102             {
103 3     3 0 7 my $self = shift;
104 3         13 my $param = $self->{param};
105              
106 3 50       8 if(not $param->{title})
107             {
108 0         0 @{$self->{cols}} = @{$self->{pcols}};
  0         0  
  0         0  
109             }
110             else
111             {
112 3         5 @{$self->{cols}} = ();
  3         7  
113 3         5 for my $cc (@{$self->{pcols}})
  3         8  
114             {
115 7 100 66     44 if($param->{title} == 1 or not $cc =~ /^\d+$/)
116             {
117 2         4 my $nc = 0; # invalid column
118 2         5 for my $i (0..$#{$self->{txd}->{titles}})
  2         9  
119             {
120             # No /o modifier, that would relate to the first value of $cc only!
121 4 100       30 if($self->{txd}->{titles}[$i] =~ m/$cc/)
122             {
123 2         6 $nc = $i+1;
124 2         4 last;
125             }
126             }
127 2         4 push(@{$self->{cols}}, $nc);
  2         5  
128             }
129 5         10 else{ push(@{$self->{cols}}, $cc); }
  5         15  
130             }
131             }
132 3         19 my $i = 0;
133 3         5 foreach my $n (@{$self->{cols}})
  3         8  
134             {
135 7         14 --$n;
136             # If we don't have titles, detecting bad columns is not possible in advance.
137             # (could only guess based on first data set, which may not be complete)
138             die "Bad column ($self->{pcols}[$i])!\n"
139             if
140             (
141             not $param->{fill} and
142             (
143             $n < 0 or
144             (
145             @{$self->{txd}->{titles}}
146 7 50 33     23 and $n > $#{$self->{txd}->{titles}}
      33        
147             )
148             )
149             );
150 7         14 ++$i;
151             }
152              
153 0         0 print STDERR "Decided on column indices: @{$self->{cols}}.\n"
154 3 50       8 if $param->{debug};
155              
156 3 50       5 if($#{$self->{txd}->{titles}} > -1)
  3         17  
157             {
158             print STDERR "Got actual titles, extracting.\n"
159 3 50       9 if $param->{debug};
160             return $self->{txd}->title_line(
161             $param->{invert} ? undef : $self->{cols}
162 3 50       18 , $param->{invert} ? $self->{cols} : undef );
    50          
163             }
164 0         0 else{ return \$self->{sline}; }
165             }
166              
167             # The actual extraction of columns is a piece of cake.
168             sub process_data
169             {
170 12     12 0 19 my $self = shift;
171 12 50       30 my $include = $self->{param}{invert} ? undef : $self->{cols};
172 12 50       22 my $exclude = $self->{param}{invert} ? $self->{cols} : undef;
173 12         19 $_[0] = ${$self->{txd}->data_line(
174 12         31 $self->{txd}->line_data($_[0]), $include, $exclude )};
175             }