File Coverage

blib/lib/Fsdb/Filter/dbcolsplittocols.pm
Criterion Covered Total %
statement 18 66 27.2
branch 0 16 0.0
condition n/a
subroutine 6 15 40.0
pod 5 5 100.0
total 29 102 28.4


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