File Coverage

blib/lib/Fsdb/Filter/dbcolcopylast.pm
Criterion Covered Total %
statement 18 64 28.1
branch 0 10 0.0
condition n/a
subroutine 6 15 40.0
pod 5 5 100.0
total 29 94 30.8


line stmt bran cond sub pod time code
1             #!/usr/bin/perl -w
2              
3             #
4             # dbcolcopylast.pm
5             # Copyright (C) 1991-2015 by John Heidemann
6             # $Id: bb2670752517f9ec2870a2baf611c24b4da7a11d $
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::dbcolcopylast;
14              
15             =head1 NAME
16              
17             dbcolcopylast - create new columns that are copies of prior columns
18              
19             =head1 SYNOPSIS
20              
21             dbcolcopylast [-e EMPTY] [column...]
22              
23              
24             =head1 DESCRIPTION
25              
26             For each COLUMN, create a new column copylast_COLUMN
27             that is the last value for that column---that is,
28             the value of that column from the row before.
29              
30              
31             =head1 OPTIONS
32              
33             =over 4
34              
35             =item B<-e> EmptyValue or B<--empty>
36              
37             Specify the value newly created columns get.
38              
39             =back
40              
41             =for comment
42             begin_standard_fsdb_options
43              
44             This module also supports the standard fsdb options:
45              
46             =over 4
47              
48             =item B<-d>
49              
50             Enable debugging output.
51              
52             =item B<-i> or B<--input> InputSource
53              
54             Read from InputSource, typically a file name, or C<-> for standard input,
55             or (if in Perl) a IO::Handle, Fsdb::IO or Fsdb::BoundedQueue objects.
56              
57             =item B<-o> or B<--output> OutputDestination
58              
59             Write to OutputDestination, typically a file name, or C<-> for standard output,
60             or (if in Perl) a IO::Handle, Fsdb::IO or Fsdb::BoundedQueue objects.
61              
62             =item B<--autorun> or B<--noautorun>
63              
64             By default, programs process automatically,
65             but Fsdb::Filter objects in Perl do not run until you invoke
66             the run() method.
67             The C<--(no)autorun> option controls that behavior within Perl.
68              
69             =item B<--help>
70              
71             Show help.
72              
73             =item B<--man>
74              
75             Show full manual.
76              
77             =back
78              
79             =for comment
80             end_standard_fsdb_options
81              
82              
83             =head1 SAMPLE USAGE
84              
85             =head2 Input:
86              
87             #fsdb test
88             a
89             b
90              
91             =head2 Command:
92              
93             cat data.fsdb | dbcolcopylast foo
94              
95             =head2 Output:
96              
97             #fsdb test foo
98             a -
99             b -
100              
101              
102             =head1 SEE ALSO
103              
104             L.
105              
106              
107             =head1 CLASS FUNCTIONS
108              
109             =cut
110              
111             @ISA = qw(Fsdb::Filter);
112             ($VERSION) = 2.0;
113              
114 1     1   5675 use strict;
  1         2  
  1         42  
115 1     1   5 use Pod::Usage;
  1         2  
  1         172  
116 1     1   8 use Carp;
  1         2  
  1         70  
117              
118 1     1   4 use Fsdb::Filter;
  1         1  
  1         22  
119 1     1   4 use Fsdb::IO::Reader;
  1         2  
  1         27  
120 1     1   4 use Fsdb::IO::Writer;
  1         2  
  1         868  
121              
122              
123             =head2 new
124              
125             $filter = new Fsdb::Filter::dbcolcopylast(@arguments);
126              
127             Create a new dbcolcopylast object, taking command-line arguments.
128              
129             =cut
130              
131             sub new ($@) {
132 0     0 1   my $class = shift @_;
133 0           my $self = $class->SUPER::new(@_);
134 0           bless $self, $class;
135 0           $self->set_defaults;
136 0           $self->parse_options(@_);
137 0           $self->SUPER::post_new();
138 0           return $self;
139             }
140              
141              
142             =head2 set_defaults
143              
144             $filter->set_defaults();
145              
146             Internal: set up defaults.
147              
148             =cut
149              
150             sub set_defaults ($) {
151 0     0 1   my($self) = @_;
152 0           $self->SUPER::set_defaults();
153 0           $self->{_copy_cols} = [];
154             }
155              
156             =head2 parse_options
157              
158             $filter->parse_options(@ARGV);
159              
160             Internal: parse command-line arguments.
161              
162             =cut
163              
164             sub parse_options ($@) {
165 0     0 1   my $self = shift @_;
166              
167 0           my(@argv) = @_;
168             $self->get_options(
169             \@argv,
170 0     0     'help|?' => sub { pod2usage(1); },
171 0     0     'man' => sub { pod2usage(-verbose => 2); },
172             'autorun!' => \$self->{_autorun},
173             'close!' => \$self->{_close},
174             'd|debug+' => \$self->{_debug},
175             'e|empty=s' => \$self->{_empty},
176 0     0     'i|input=s' => sub { $self->parse_io_option('input', @_); },
177             'log!' => \$self->{_logprog},
178 0     0     'o|output=s' => sub { $self->parse_io_option('output', @_); },
179 0 0         ) or pod2usage(2);
180 0           push (@{$self->{_copy_cols}}, @argv);
  0            
181             }
182              
183             =head2 setup
184              
185             $filter->setup();
186              
187             Internal: setup, parse headers.
188              
189             =cut
190              
191             sub setup ($) {
192 0     0 1   my($self) = @_;
193              
194 0           $self->finish_io_option('input', -comment_handler => $self->create_pass_comments_sub);
195 0           $self->finish_io_option('output', -clone => $self->{_in}, -outputheader => 'delay');
196              
197 0           my $init_code = '';
198 0           my $copy_code = '';
199 0           foreach (@{$self->{_copy_cols}}) {
  0            
200 0           my($source_coli) = $self->{_in}->col_to_i($_);
201 0 0         croak $self->{_prog} . ": attempt to copy non-existing column $_.\n"
202             if (!defined($source_coli));
203              
204 0           my($dest_col) = "copylast_" . $_;
205             $self->{_out}->col_create($dest_col)
206 0 0         or croak $self->{_prog} . ": cannot create column '$dest_col' (maybe it already existed?)\n";
207 0           my($dest_coli) = $self->{_out}->col_to_i($dest_col);
208              
209 0           $init_code .= '$lfref->[' . $source_coli . '] = $empty;' . "\n";
210 0           $copy_code .= '$fref->[' . $dest_coli . '] = $lfref->[' . $source_coli . '];' . "\n";
211             };
212            
213             #
214             # write the loop
215             #
216             {
217 0           my $loop_sub;
  0            
218 0           my $read_fastpath_sub = $self->{_in}->fastpath_sub();
219 0           my $write_fastpath_sub = $self->{_out}->fastpath_sub();
220 0           my $empty = $self->{_empty};
221 0           my $loop_sub_code = q'
222             $loop_sub = sub {
223             my $fref;
224             my $lfref;
225             ' . $init_code . q'
226             while ($fref = &$read_fastpath_sub()) {
227             ' . $copy_code . q'
228             &$write_fastpath_sub($fref);
229             $lfref = $fref; # save for next pass
230             };
231             };
232             ';
233 0 0         print $loop_sub_code if ($self->{_debug});
234 0           eval $loop_sub_code;
235 0 0         $@ && die $self->{_prog} . ": internal eval error: $@.\n";
236 0           $self->{_loop_sub} = $loop_sub;
237             }
238             }
239              
240              
241             =head2 run
242              
243             $filter->run();
244              
245             Internal: run over each rows.
246              
247             =cut
248             sub run ($) {
249 0     0 1   my($self) = @_;
250 0           &{$self->{_loop_sub}}();
  0            
251             }
252              
253              
254             =head1 AUTHOR and COPYRIGHT
255              
256             Copyright (C) 1991-2015 by John Heidemann
257              
258             This program is distributed under terms of the GNU general
259             public license, version 2. See the file COPYING
260             with the distribution for details.
261              
262             =cut
263              
264             1;