File Coverage

blib/lib/Fsdb/Filter/dbcolcreate.pm
Criterion Covered Total %
statement 18 87 20.6
branch 0 26 0.0
condition n/a
subroutine 6 16 37.5
pod 5 5 100.0
total 29 134 21.6


line stmt bran cond sub pod time code
1             #!/usr/bin/perl -w
2              
3             #
4             # dbcolcreate.pm
5             # Copyright (C) 1991-2015 by John Heidemann
6             # $Id: 216a06b5b795af4bf85c8c70b3b7fdc22ddf85b4 $
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::dbcolcreate;
14              
15             =head1 NAME
16              
17             dbcolcreate - create new columns
18              
19             =head1 SYNOPSIS
20              
21             dbcolcreate NewColumn1 [NewColumn2]
22              
23             or
24              
25             dbcolcreate -e DefaultValue NewColumnWithDefault
26              
27             =head1 DESCRIPTION
28              
29             Create columns C, etc.
30             with an optional C.
31              
32              
33             =head1 OPTIONS
34              
35             =over 4
36              
37             =item B<-e> EmptyValue or B<--empty>
38              
39             Specify the value newly created columns get.
40              
41             =item B<-f> or B<--first>
42              
43             Put all new columns as the first columns of each row.
44             By default, they go at the end of each row.
45              
46             =item B<--no-recreate-fatal>
47              
48             By default, creating an existing column is an error.
49             With B<--no-recreate-fatal>, we ignore re-creation.
50              
51             =back
52              
53             =for comment
54             begin_standard_fsdb_options
55              
56             This module also supports the standard fsdb options:
57              
58             =over 4
59              
60             =item B<-d>
61              
62             Enable debugging output.
63              
64             =item B<-i> or B<--input> InputSource
65              
66             Read from InputSource, typically a file name, or C<-> for standard input,
67             or (if in Perl) a IO::Handle, Fsdb::IO or Fsdb::BoundedQueue objects.
68              
69             =item B<-o> or B<--output> OutputDestination
70              
71             Write to OutputDestination, typically a file name, or C<-> for standard output,
72             or (if in Perl) a IO::Handle, Fsdb::IO or Fsdb::BoundedQueue objects.
73              
74             =item B<--autorun> or B<--noautorun>
75              
76             By default, programs process automatically,
77             but Fsdb::Filter objects in Perl do not run until you invoke
78             the run() method.
79             The C<--(no)autorun> option controls that behavior within Perl.
80              
81             =item B<--help>
82              
83             Show help.
84              
85             =item B<--man>
86              
87             Show full manual.
88              
89             =back
90              
91             =for comment
92             end_standard_fsdb_options
93              
94              
95             =head1 SAMPLE USAGE
96              
97             =head2 Input:
98              
99             #fsdb test
100             a
101             b
102              
103             =head2 Command:
104              
105             cat data.fsdb | dbcolcreate foo
106              
107             =head2 Output:
108              
109             #fsdb test foo
110             a -
111             b -
112              
113              
114             =head1 SEE ALSO
115              
116             L.
117              
118              
119             =head1 CLASS FUNCTIONS
120              
121             =cut
122              
123             @ISA = qw(Fsdb::Filter);
124             ($VERSION) = 2.0;
125              
126 1     1   3834 use strict;
  1         2  
  1         25  
127 1     1   15 use Pod::Usage;
  1         2  
  1         77  
128 1     1   3 use Carp;
  1         1  
  1         46  
129              
130 1     1   3 use Fsdb::Filter;
  1         1  
  1         26  
131 1     1   3 use Fsdb::IO::Reader;
  1         1  
  1         16  
132 1     1   2 use Fsdb::IO::Writer;
  1         1  
  1         610  
133              
134              
135             =head2 new
136              
137             $filter = new Fsdb::Filter::dbcolcreate(@arguments);
138              
139             Create a new dbcolcreate object, taking command-line arguments.
140              
141             =cut
142              
143             sub new ($@) {
144 0     0 1   my $class = shift @_;
145 0           my $self = $class->SUPER::new(@_);
146 0           bless $self, $class;
147 0           $self->set_defaults;
148 0           $self->parse_options(@_);
149 0           $self->SUPER::post_new();
150 0           return $self;
151             }
152              
153              
154             =head2 set_defaults
155              
156             $filter->set_defaults();
157              
158             Internal: set up defaults.
159              
160             =cut
161              
162             sub set_defaults ($) {
163 0     0 1   my($self) = @_;
164 0           $self->SUPER::set_defaults();
165 0           $self->{_creations} = [];
166 0           $self->{_first} = undef;
167 0           $self->{_create_values} = {};
168 0           $self->{_recreate_fatal} = 1;
169             }
170              
171             =head2 parse_options
172              
173             $filter->parse_options(@ARGV);
174              
175             Internal: parse command-line arguments.
176              
177             =cut
178              
179             sub parse_options ($@) {
180 0     0 1   my $self = shift @_;
181              
182 0           my(@argv) = @_;
183             $self->get_options(
184             \@argv,
185 0     0     'help|?' => sub { pod2usage(1); },
186 0     0     'man' => sub { pod2usage(-verbose => 2); },
187             'autorun!' => \$self->{_autorun},
188             'close!' => \$self->{_close},
189             'd|debug+' => \$self->{_debug},
190             'e|empty=s' => \$self->{_empty},
191             'f|first!' => \$self->{_first},
192 0     0     'i|input=s' => sub { $self->parse_io_option('input', @_); },
193             'recreate-fatal!' => \$self->{_recreate_fatal},
194             'log!' => \$self->{_logprog},
195 0     0     'o|output=s' => sub { $self->parse_io_option('output', @_); },
196             '<>' => sub {
197 0     0     my($target) = @_;
198 0 0         if ($target eq '-') {
199 0           warn "dbcolcreate: appear to be using fsdb-1 dual argument syntax. Replace \"NewCol DefaultValue\" with \"-e DefaultValue NewCol\".\n";
200 0           return;
201             };
202 0           push(@{$self->{_creations}}, $target);
  0            
203 0           $self->{_create_values}{$target} = $self->{_empty};
204             },
205 0 0         ) or pod2usage(2);
206 0 0         pod2usage(2) if ($#argv != -1);
207             }
208              
209             =head2 setup
210              
211             $filter->setup();
212              
213             Internal: setup, parse headers.
214              
215             =cut
216              
217             sub setup ($) {
218 0     0 1   my($self) = @_;
219              
220             croak $self->{_prog} . ": no new columns to create.\n"
221 0 0         if ($#{$self->{_creations}} == -1);
  0            
222              
223 0           $self->finish_io_option('input', -comment_handler => $self->create_pass_comments_sub);
224              
225 0           my @new_cols = @{$self->{_in}->cols};
  0            
226 0           my %existing_cols;
227 0           foreach (@new_cols) {
228 0           $existing_cols{$_} = 1;
229             };
230 0 0         my $coli = ($self->{_first} ? 0 : $#new_cols);
231 0           my $insert_args = '';
232 0           foreach (@{$self->{_creations}}) {
  0            
233 0 0         if (defined($existing_cols{$_})) {
234 0 0         next if (!$self->{_recreate_fatal});
235 0           croak $self->{_prog} . ": attempt to create pre-existing column $_.\n"
236             };
237 0           $coli++;
238 0 0         if ($self->{_first}) {
239 0           unshift @new_cols, $_;
240             } else {
241 0           push @new_cols, $_;
242             };
243 0           $existing_cols{$_} = 2;
244 0           my $val = $self->{_create_values}{$_};
245 0           my $quote = "'";
246 0 0         if ($val =~ /\'/) {
247 0           $quote = '|';
248 0 0         croak $self->{_prog} . ": internal error: cannot find reasonable way to do quoting.\n"
249             if ($val =~ /\|/);
250             };
251 0           $insert_args .= "\t\t, q" . $quote . $val . $quote . "\n";
252             };
253 0 0         my $insert_code = "\t" . ($self->{_first} ? "unshift" : "push") . '(@$fref' . $insert_args . ");\n";
254             #
255             # A fun case, exercised by TEST/dbmapreduce_dbrowenumerate.cmd:
256             #
257             # IF we are invoked with --no-recreate-fatal
258             # AND the column we're creating already exists,
259             # THEN we end up with nothing to create.
260             # The result is this obscure warning:
261             # Useless use of unshift with no values at (eval 37) line 5, line 1.
262             #
263             # To fix that case, we turn ourselves into a pass-through loop.
264             #
265 0 0         $insert_code = '' if ($insert_args eq '');
266              
267 0           $self->finish_io_option('output', -clone => $self->{_in}, -cols => \@new_cols);
268            
269             #
270             # write the loop
271             #
272             {
273 0           my $loop_sub;
  0            
274 0           my $read_fastpath_sub = $self->{_in}->fastpath_sub();
275 0           my $write_fastpath_sub = $self->{_out}->fastpath_sub();
276 0           my $loop_sub_code = q'
277             $loop_sub = sub {
278             my $fref;
279             while ($fref = &$read_fastpath_sub()) {
280             ' . $insert_code . q'
281             &$write_fastpath_sub($fref);
282             };
283             };
284             ';
285 0           eval $loop_sub_code;
286 0 0         $@ && die $self->{_prog} . ": internal eval error: $@.\n";
287 0           $self->{_loop_sub} = $loop_sub;
288             }
289             }
290              
291              
292             =head2 run
293              
294             $filter->run();
295              
296             Internal: run over each rows.
297              
298             =cut
299             sub run ($) {
300 0     0 1   my($self) = @_;
301 0           &{$self->{_loop_sub}}();
  0            
302             }
303              
304              
305             =head1 AUTHOR and COPYRIGHT
306              
307             Copyright (C) 1991-2015 by John Heidemann
308              
309             This program is distributed under terms of the GNU general
310             public license, version 2. See the file COPYING
311             with the distribution for details.
312              
313             =cut
314              
315             1;