File Coverage

blib/lib/Text/NumericData/App/txdcolumns.pm
Criterion Covered Total %
statement 56 61 91.8
branch 11 16 68.7
condition 4 9 44.4
subroutine 8 8 100.0
pod 0 6 0.0
total 79 100 79.0


line stmt bran cond sub pod time code
1             package Text::NumericData::App::txdcolumns;
2              
3 1     1   66944 use Text::NumericData::App;
  1         6  
  1         38  
4              
5 1     1   9 use strict;
  1         3  
  1         1295  
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 119 my $class = shift;
25 1         9 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             , 'title','-1','',
30             '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/'
31             , 'debug', 0, '', 'print some stuff to stderr to help debugging'
32             );
33              
34 1         30 return $class->SUPER::new
35             ({
36             parconf =>
37             {
38             info=>$infostring # default version
39             # default author
40             # default copyright
41             }
42             ,pardef => \@pars
43             ,pipemode => 1
44             ,pipe_init => \&preinit
45             ,pipe_begin => \&init
46             ,pipe_header => \&process_header
47             ,pipe_first_data => \&process_first_data
48             ,pipe_data => \&process_data
49             });
50             }
51              
52             sub preinit
53             {
54 3     3 0 9 my $self = shift;
55 3         9 my $param = $self->{param};
56              
57             $self->{pcols} = defined $param->{columns}
58 3 100       19 ? [split(/\s*,\s*/, $param->{columns})]
59             : [];
60 3         9 push(@{$self->{pcols}}, @{$self->{argv}});
  3         11  
  3         12  
61             #print STDERR "You really want NO data?\n" unless @pcols;
62 3         13 return 0;
63             }
64              
65             sub init
66             {
67 3     3 0 334 my $self = shift;
68              
69 3         26 $self->new_txd();
70 3         11 $self->{cols} = [];
71 3         12 $self->{sline} = '';
72             }
73              
74             # Delay header printout for processing column headers.
75             sub process_header
76             {
77 6     6 0 16 my $self = shift;
78 6         15 my $sline = $_[0];
79 6         15 $_[0] = $self->{sline};
80 6         18 $self->{sline} = $sline;
81             }
82              
83             # This is the ugly part, deriving the columns and column headers to use.
84             sub process_first_data
85             {
86 3     3 0 15 my $self = shift;
87 3         9 my $param = $self->{param};
88              
89 3 50       9 if(not $param->{title})
90             {
91 0         0 @{$self->{cols}} = @{$self->{pcols}};
  0         0  
  0         0  
92             }
93             else
94             {
95 3         8 @{$self->{cols}} = ();
  3         9  
96 3         8 for my $cc (@{$self->{pcols}})
  3         15  
97             {
98 7 100 66     54 if($param->{title} == 1 or not $cc =~ /^\d+$/)
99             {
100 2         6 my $nc = 0; # invalid column
101 2         5 for my $i (0..$#{$self->{txd}->{titles}})
  2         10  
102             {
103             # No /o modifier, that would relate to the first value of $cc only!
104 4 100       34 if($self->{txd}->{titles}[$i] =~ m/$cc/)
105             {
106 2         7 $nc = $i+1;
107 2         6 last;
108             }
109             }
110 2         5 push(@{$self->{cols}}, $nc);
  2         8  
111             }
112 5         12 else{ push(@{$self->{cols}}, $cc); }
  5         20  
113             }
114             }
115 3         7 my $i = 0;
116 3         8 foreach my $n (@{$self->{cols}})
  3         9  
117             {
118 7         16 --$n;
119             # If we don't have titles, detecting bad columns is not possible in advance.
120             # (could only guess based on first data set, which may not be complete)
121             die "Bad column ($self->{pcols}[$i])!\n"
122             if
123             (
124             not $param->{fill} and
125             (
126             $n < 0 or
127             (
128             @{$self->{txd}->{titles}}
129 7 50 33     31 and $n > $#{$self->{txd}->{titles}}
      33        
130             )
131             )
132             );
133 7         18 ++$i;
134             }
135              
136 0         0 print STDERR "Decided on column indices: @{$self->{cols}}.\n"
137 3 50       11 if $param->{debug};
138              
139 3 50       6 if($#{$self->{txd}->{titles}} > -1)
  3         13  
140             {
141             print STDERR "Got actual titles, extracting.\n"
142 3 50       11 if $param->{debug};
143 3         20 return $self->{txd}->title_line($self->{cols});
144             }
145 0         0 else{ return \$self->{sline}; }
146             }
147              
148             # The actual extraction of columns is a piece of cake.
149             sub process_data
150             {
151 12     12 0 28 my $self = shift;
152 12         22 $_[0] = ${$self->{txd}->data_line(
153 12         51 $self->{txd}->line_data($_[0]),$self->{cols} )};
154             }