File Coverage

blib/lib/Fsdb/Filter/dbcol.pm
Criterion Covered Total %
statement 15 88 17.0
branch 0 24 0.0
condition n/a
subroutine 5 15 33.3
pod 6 6 100.0
total 26 133 19.5


line stmt bran cond sub pod time code
1             #!/usr/bin/perl -w
2              
3             #
4             # dbcol.pm
5             # Copyright (C) 1991-2015 by John Heidemann
6             # $Id: 2607991a5498804e1c6e26d652175fe92db98515 $
7             #
8             # This program is distributed under terms of the GNU general
9             # public license, version 2. See the file COPYING
10             # in $dblibdir for details.
11             #
12              
13             package Fsdb::Filter::dbcol;
14              
15             =head1 NAME
16              
17             dbcol - select columns from an Fsdb file
18              
19             =head1 SYNOPSIS
20              
21             dbcol [-v] [-e -] [column...]
22              
23             =head1 DESCRIPTION
24              
25             Select one or more columns from the input database.
26             If a value is given for empty columns with the -e option,
27             then any named columns which don't exist will be created.
28             Otherwise, non-existent columns are an error.
29              
30             Note: a safer way to create columns is dbcolcreate.
31              
32             =head1 OPTIONS
33              
34             =over 4
35              
36             =item B<-r> or B<--relaxed-errors>
37              
38             Relaxed error checking: ignore columns that aren't there.
39              
40             =item B<-v> or B<--invert-match>
41              
42             Output all columns except those listed (like grep -v).
43              
44             =item B<-e> EmptyValue or B<--empty>
45              
46             Specify the value newly created columns get.
47              
48             =back
49              
50             =for comment
51             begin_standard_fsdb_options
52              
53             and the standard fsdb options:
54              
55             =over 4
56              
57             =item B<-d>
58              
59             Enable debugging output.
60              
61             =item B<-i> or B<--input> InputSource
62              
63             Read from InputSource, typically a file, or - for standard input,
64             or (if in Perl) a IO::Handle, Fsdb::IO or Fsdb::BoundedQueue objects.
65              
66             =item B<-o> or B<--output> OutputDestination
67              
68             Write to OutputDestination, typically a file, or - for standard output,
69             or (if in Perl) a IO::Handle, Fsdb::IO or Fsdb::BoundedQueue objects.
70              
71             =item B<--autorun> or B<--noautorun>
72              
73             By default, programs process automatically,
74             but Fsdb::Filter objects in Perl do not run until you invoke
75             the run() method.
76             The C<--(no)autorun> option controls that behavior within Perl.
77              
78             =item B<--header> H
79              
80             Use H as the full Fsdb header, rather than reading a header from
81             then input.
82              
83             =item B<--help>
84              
85             Show help.
86              
87             =item B<--man>
88              
89             Show full manual.
90              
91             =back
92              
93             =for comment
94             end_standard_fsdb_options
95              
96              
97             =head1 SAMPLE USAGE
98              
99             =head2 Input:
100              
101             #fsdb account passwd uid gid fullname homedir shell
102             johnh * 2274 134 John_Heidemann /home/johnh /bin/bash
103             greg * 2275 134 Greg_Johnson /home/greg /bin/bash
104             root * 0 0 Root /root /bin/bash
105             # this is a simple database
106              
107             =head2 Command:
108              
109             cat DATA/passwd.fsdb account | dbcol account
110              
111             =head2 Output:
112              
113             #fsdb account
114             johnh
115             greg
116             root
117             # this is a simple database
118             # | dbcol account
119              
120              
121             =head1 SEE ALSO
122              
123             L,
124             L
125              
126             =head1 CLASS FUNCTIONS
127              
128             =cut
129              
130             @ISA = qw(Fsdb::Filter);
131             ($VERSION) = 2.0;
132              
133 1     1   4118 use strict;
  1         2  
  1         23  
134 1     1   4 use Pod::Usage;
  1         1  
  1         64  
135              
136 1     1   3 use Fsdb::Filter;
  1         1  
  1         14  
137 1     1   3 use Fsdb::IO::Reader;
  1         1  
  1         18  
138 1     1   2 use Fsdb::IO::Writer;
  1         1  
  1         700  
139              
140              
141             =head2 new
142              
143             $filter = new Fsdb::Filter::dbcol(@arguments);
144              
145             Create a new dbcol object, taking command-line arguments.
146              
147             =cut
148              
149             sub new {
150 0     0 1   my $class = shift @_;
151 0           my $self = $class->SUPER::new(@_);
152 0           bless $self, $class;
153 0           $self->set_defaults;
154 0           $self->parse_options(@_);
155 0           $self->SUPER::post_new();
156 0           return $self;
157             }
158              
159              
160             =head2 set_defaults
161              
162             $filter->set_defaults();
163              
164             Internal: set up defaults.
165              
166             =cut
167              
168             sub set_defaults ($) {
169 0     0 1   my($self) = @_;
170 0           $self->SUPER::set_defaults();
171 0           $self->{_null_value} = undef;
172 0           $self->{_invert_match} = undef;
173 0           $self->{_relaxed_errors} = undef;
174 0           $self->{_header} = undef;
175             }
176              
177             =head2 parse_options
178              
179             $filter->parse_options(@ARGV);
180              
181             Internal: parse options
182              
183             =cut
184              
185             sub parse_options ($@) {
186 0     0 1   my $self = shift @_;
187              
188 0           my(@arg_cols) = @_;
189             $self->get_options(
190             \@arg_cols,
191 0     0     'help|?' => sub { pod2usage(1); },
192 0     0     'man' => sub { pod2usage(-verbose => 2); },
193             'autorun!' => \$self->{_autorun},
194             'close!' => \$self->{_close},
195             'd|debug+' => \$self->{_debug},
196             'e|empty=s' => \$self->{_null_value},
197             'header=s' => \$self->{_header},
198 0     0     'i|input=s' => sub { $self->parse_io_option('input', @_); },
199             'log!' => \$self->{_logprog},
200 0     0     'o|output=s' => sub { $self->parse_io_option('output', @_); },
201             'r|relaxed-errors!' => \$self->{_relaxed_errors},
202             'v|invert-match!' => \$self->{_invert_match}
203 0 0         ) or pod2usage(2);
204 0           push (@{$self->{_arg_cols}}, @arg_cols);
  0            
205             }
206              
207             =head2 setup
208              
209             $filter->setup();
210              
211             Internal: setup, parse headers.
212              
213             =cut
214              
215             sub setup ($) {
216 0     0 1   my($self) = @_;
217              
218 0           my(@in_options) = (-comment_handler => $self->create_pass_comments_sub);
219 0 0         push(@in_options, -header => $self->{_header}) if (defined($self->{_header}));
220 0           $self->finish_io_option('input', @in_options);
221 0           my $read_fastpath_sub = $self->{_in}->fastpath_sub();
222              
223 0           my @new_arg_cols = ();
224 0 0         if ($self->{_invert_match}) {
225 0           my %bad_cols;
226 0           foreach (@{$self->{_arg_cols}}) {
  0            
227 0           my($badf) = $self->{_in}->col_to_i($_);
228 0 0         if (!defined($badf)) {
229             die $self->{_prog} . ": unknown column ``$_'' for omission.\n"
230 0 0         if (!$self->{_relaxed_errors});
231             # skip it if relaxed
232 0           next;
233             };
234 0           my($badn) = $self->{_in}->i_to_col($badf);
235 0           $bad_cols{$badn} = 1;
236             };
237             # rebuild list from survivors
238 0           foreach (@{$self->{_in}->cols}) {
  0            
239 0 0         push(@new_arg_cols, $_) if (!$bad_cols{$_});
240             };
241             } else {
242             # convert any numeric colnames to names
243 0           foreach (@{$self->{_arg_cols}}) {
  0            
244             push(@new_arg_cols, defined($self->{_in}->col_to_i($_)) ?
245 0 0         $self->{_in}->i_to_col($self->{_in}->col_to_i($_)) :
246             $_);
247             };
248             };
249 0           @{$self->{_arg_cols}} = @new_arg_cols;
  0            
250              
251             #
252             # setup conversion
253             #
254 0           my($copy_code) = "";
255 0           my(%new_colnames);
256 0           for my $out_coli (0..$#{$self->{_arg_cols}}) {
  0            
257 0           my $colname = $self->{_arg_cols}[$out_coli];
258             die $self->{_prog} . ": duplicate colname $colname\n"
259 0 0         if (defined($new_colnames{$colname}));
260 0           $new_colnames{$colname} = $out_coli;
261 0           my $in_coli = $self->{_in}->col_to_i($colname);
262 0 0         if (defined($in_coli)) {
    0          
263 0           $copy_code .= '$nf['.$out_coli.'] = $fref->['.$in_coli.'];' . "\n";
264             } elsif (!defined($self->{_null_value})) {
265 0           die ($self->{_prog} . ": creating new column ``$colname'' without specifying null value.\n");
266             } else {
267 0           $copy_code .= '$nf['.$out_coli."] = '" . $self->{_null_value} . "';\n";
268             };
269             };
270              
271             #
272             # setup output
273             #
274 0           $self->finish_io_option('output', -clone => $self->{_in}, -cols => \@{$self->{_arg_cols}});
  0            
275 0           my $write_fastpath_sub = $self->{_out}->fastpath_sub();
276              
277             #
278             # write the loop
279             #
280             # Since perl5 doesn't cache eval, eval the whole loop.
281             #
282             # This is very hairy. Use the eval to pull in the copy code,
283             # and wrap it in an anon subroutine that we store away.
284             # We have to do all this HERE, rather than in run,
285             # because $read_fastpath_sub is local to here.
286             #
287             {
288 0           my $loop_sub;
  0            
289 0           my $loop_sub_code = q'
290             $loop_sub = sub {
291             my $fref;
292             my @nf;
293             while ($fref = &$read_fastpath_sub()) {
294             ' . $copy_code . q'
295             &$write_fastpath_sub(\@nf);
296             };
297             };
298             ';
299 0           eval $loop_sub_code;
300 0 0         $@ && die $self->{_prog} . ": internal eval error: $@.\n";
301 0           $self->{_loop_sub} = $loop_sub;
302             }
303             }
304              
305             =head2 run
306              
307             $filter->run();
308              
309             Internal: run over all data rows.
310              
311             =cut
312             sub run ($) {
313 0     0 1   my($self) = @_;
314 0           &{$self->{_loop_sub}}();
  0            
315             }
316              
317             =head2 finish
318              
319             $filter->finish();
320              
321             Internal: write trailer.
322              
323             =cut
324             sub finish ($) {
325 0     0 1   my($self) = @_;
326              
327             $self->{_out}->write_comment($self->{_prog} . "\'s code: " . code_prettify($self->{_loop_code}))
328 0 0         if ($self->{_debug});
329 0           $self->SUPER::finish();
330             }
331              
332             =head1 AUTHOR and COPYRIGHT
333              
334             Copyright (C) 1991-2015 by John Heidemann
335              
336             This program is distributed under terms of the GNU general
337             public license, version 2. See the file COPYING
338             with the distribution for details.
339              
340             =cut
341              
342             1;
343