File Coverage

blib/lib/Fsdb/Filter/dbcolmerge.pm
Criterion Covered Total %
statement 18 72 25.0
branch 0 18 0.0
condition n/a
subroutine 6 15 40.0
pod 5 5 100.0
total 29 110 26.3


line stmt bran cond sub pod time code
1             #!/usr/bin/perl
2              
3             #
4             # dbcolmerge.pm
5             # Copyright (C) 1991-2008 by John Heidemann
6             # $Id: 3dfd25a93416ff66eb1930699b1eacadcf68d9b3 $
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::dbcolmerge;
14              
15             =head1 NAME
16              
17             dbcolmerge - merge multiple columns into one
18              
19             =head1 SYNOPSIS
20              
21             dbcolmerge [-C ElementSeparator] [columns...]
22              
23             =head1 DESCRIPTION
24              
25             For each row, merge multiple columns down to a single column,
26             joining elements with ElementSeparator (defaults to a single underscore).
27              
28             =head1 OPTIONS
29              
30             =over 4
31              
32             =item B<-C S> or B<--element-separator S>
33              
34             Specify the separator used to join columns.
35             (Defaults to a single underscore.)
36              
37             =item B<-e E> or B<--empty E>
38              
39             give value E as the value for empty (null) records
40              
41             =back
42              
43             =for comment
44             begin_standard_fsdb_options
45              
46             This module also supports the standard fsdb options:
47              
48             =over 4
49              
50             =item B<-d>
51              
52             Enable debugging output.
53              
54             =item B<-i> or B<--input> InputSource
55              
56             Read from InputSource, typically a file name, or C<-> for standard input,
57             or (if in Perl) a IO::Handle, Fsdb::IO or Fsdb::BoundedQueue objects.
58              
59             =item B<-o> or B<--output> OutputDestination
60              
61             Write to OutputDestination, typically a file name, or C<-> for standard output,
62             or (if in Perl) a IO::Handle, Fsdb::IO or Fsdb::BoundedQueue objects.
63              
64             =item B<--autorun> or B<--noautorun>
65              
66             By default, programs process automatically,
67             but Fsdb::Filter objects in Perl do not run until you invoke
68             the run() method.
69             The C<--(no)autorun> option controls that behavior within Perl.
70              
71             =item B<--header H>
72              
73             Use H as the full Fsdb header, rather than reading a header from
74             then input.
75              
76             =item B<--help>
77              
78             Show help.
79              
80             =item B<--man>
81              
82             Show full manual.
83              
84             =back
85              
86             =for comment
87             end_standard_fsdb_options
88              
89              
90             =head1 SAMPLE USAGE
91              
92             =head2 Input:
93              
94             #fsdb first last
95             John Heidemann
96             Greg Johnson
97             Root -
98             # this is a simple database
99             # | /home/johnh/BIN/DB/dbcol fullname
100             # | dbcolrename fullname first_last
101             # | /home/johnh/BIN/DB/dbcolsplit -C _ first_last
102             # | /home/johnh/BIN/DB/dbcol first last
103              
104             =head2 Command:
105              
106             cat data.fsdb | dbcolmerge -C _ first last
107              
108             =head2 Output:
109              
110             #fsdb first last first_last
111             John Heidemann John_Heidemann
112             Greg Johnson Greg_Johnson
113             Root - Root_
114             # this is a simple database
115             # | /home/johnh/BIN/DB/dbcol fullname
116             # | dbcolrename fullname first_last
117             # | /home/johnh/BIN/DB/dbcolsplit first_last
118             # | /home/johnh/BIN/DB/dbcol first last
119             # | /home/johnh/BIN/DB/dbcolmerge -C _ first last
120              
121              
122             =head1 SEE ALSO
123              
124             L.
125             L.
126             L.
127             L.
128              
129              
130             =head1 CLASS FUNCTIONS
131              
132             =cut
133              
134             @ISA = qw(Fsdb::Filter);
135             $VERSION = 2.0;
136              
137 1     1   3951 use strict;
  1         2  
  1         25  
138 1     1   3 use Pod::Usage;
  1         2  
  1         74  
139 1     1   4 use Carp;
  1         2  
  1         42  
140              
141 1     1   3 use Fsdb::Filter;
  1         2  
  1         14  
142 1     1   3 use Fsdb::IO::Reader;
  1         1  
  1         16  
143 1     1   3 use Fsdb::IO::Writer;
  1         1  
  1         623  
144              
145              
146             =head2 new
147              
148             $filter = new Fsdb::Filter::dbcolmerge(@arguments);
149              
150             Create a new dbcolmerge object, taking command-line arguments.
151              
152             =cut
153              
154             sub new ($@) {
155 0     0 1   my $class = shift @_;
156 0           my $self = $class->SUPER::new(@_);
157 0           bless $self, $class;
158 0           $self->set_defaults;
159 0           $self->parse_options(@_);
160 0           $self->SUPER::post_new();
161 0           return $self;
162             }
163              
164              
165             =head2 set_defaults
166              
167             $filter->set_defaults();
168              
169             Internal: set up defaults.
170              
171             =cut
172              
173             sub set_defaults ($) {
174 0     0 1   my($self) = @_;
175 0           $self->SUPER::set_defaults();
176 0           $self->{_elem_separator} = '_';
177 0           $self->{_merge_columns} = [];
178 0           $self->{_header} = undef;
179             }
180              
181             =head2 parse_options
182              
183             $filter->parse_options(@ARGV);
184              
185             Internal: parse command-line arguments.
186              
187             =cut
188              
189             sub parse_options ($@) {
190 0     0 1   my $self = shift @_;
191              
192 0           my(@argv) = @_;
193             $self->get_options(
194             \@argv,
195 0     0     'help|?' => sub { pod2usage(1); },
196 0     0     'man' => sub { pod2usage(-verbose => 2); },
197             'autorun!' => \$self->{_autorun},
198             'close!' => \$self->{_close},
199             'C|element-separator=s' => \$self->{_elem_separator},
200             'd|debug+' => \$self->{_debug},
201             'e|empty=s' => \$self->{_empty},
202             'header=s' => \$self->{_header},
203 0     0     'i|input=s' => sub { $self->parse_io_option('input', @_); },
204             'log!' => \$self->{_logprog},
205 0     0     'o|output=s' => sub { $self->parse_io_option('output', @_); },
206 0 0         ) or pod2usage(2);
207 0           push (@{$self->{_merge_columns}}, @argv);
  0            
208             }
209              
210             =head2 setup
211              
212             $filter->setup();
213              
214             Internal: setup, parse headers.
215              
216             =cut
217              
218             sub setup ($) {
219 0     0 1   my($self) = @_;
220              
221             # Sanity check user's input to avoid injection attacks.
222             croak $self->{_prog} . ": bad element separator.\n"
223 0 0         if ($self->{_elem_separator} =~ /\'/);
224              
225             croak $self->{_prog} . ": no columns to merge selected.\n"
226 0 0         if ($#{$self->{_merge_columns}} == -1);
  0            
227              
228 0           my(@finish_args) = (-comment_handler => $self->create_pass_comments_sub);
229 0 0         push (@finish_args, -header => $self->{_header}) if (defined($self->{_header}));
230 0           $self->finish_io_option('input', @finish_args);
231              
232 0           $self->finish_io_option('output', -clone => $self->{_in}, -outputheader => 'delay');
233 0           $self->{_merged_colname} = join($self->{_elem_separator}, @{$self->{_merge_columns}});
  0            
234             $self->{_out}->col_create($self->{_merged_colname})
235 0 0         or croak $self->{_prog} . ": cannot create column " . $self->{_merged_colname} . " (maybe it already existed?)\n";
236 0           $self->{_merged_coli} = $self->{_out}->col_to_i($self->{_merged_colname});
237              
238             #
239             # Write the code to do the merge, and check stuff on the way.
240             #
241 0           my $code = '';
242 0           my $joiner = '';
243 0           my $empty = $self->{_empty};
244 0 0         croak "bad empty value: $empty\n" if ($empty eq "'");
245 0           $code = '$fref->[' . $self->{_merged_coli} . '] = ';
246 0           foreach (@{$self->{_merge_columns}}) {
  0            
247 0           my $i = $self->{_in}->col_to_i($_);
248 0 0         croak ($self->{_prog} . ": unknown column ``$_''.\n")
249             if (!defined($i));
250 0           my $f = '$fref->[' . $i . ']';
251 0           $code .= "$joiner ($f eq '$empty' ? '' : $f) ";
252 0           $joiner = " . '" . $self->{_elem_separator} . "' . ";
253             };
254 0           $code .= ';';
255 0           $self->{_join_code} = $code;
256             }
257              
258             =head2 run
259              
260             $filter->run();
261              
262             Internal: run over each rows.
263              
264             =cut
265             sub run ($) {
266 0     0 1   my($self) = @_;
267              
268 0           my $read_fastpath_sub = $self->{_in}->fastpath_sub();
269 0           my $write_fastpath_sub = $self->{_out}->fastpath_sub();
270              
271             my($loop) = q'{
272             my $fref;
273             while ($fref = &$read_fastpath_sub()) {
274 0           ' . $self->{_join_code} . q'
275             &$write_fastpath_sub($fref);
276             };
277             }';
278 0 0         print $loop if ($self->{_debug});
279 0           eval $loop;
280 0 0         $@ && croak $self->{_prog} . ": interal eval error: $@.\n";
281             }
282              
283             =head1 AUTHOR and COPYRIGHT
284              
285             Copyright (C) 1991-2008 by John Heidemann
286              
287             This program is distributed under terms of the GNU general
288             public license, version 2. See the file COPYING
289             with the distribution for details.
290              
291             =cut
292              
293             1;