File Coverage

blib/lib/Fsdb/Filter/dbrowaccumulate.pm
Criterion Covered Total %
statement 21 71 29.5
branch 0 26 0.0
condition 0 9 0.0
subroutine 7 16 43.7
pod 5 5 100.0
total 33 127 25.9


line stmt bran cond sub pod time code
1             #!/usr/bin/perl -w
2              
3             #
4             # dbrowaccumulate.pm
5             # Copyright (C) 1991-2007 by John Heidemann
6             # $Id: 1357ab139e05543b0b6d4c43607af46e804305e7 $
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              
14             package Fsdb::Filter::dbrowaccumulate;
15              
16             =head1 NAME
17              
18             dbrowaccumulate - compute a running sum of a column
19              
20             =head1 SYNOPSIS
21              
22             dbrowaccumulate [-C increment_constant] [-I initial_value] [-c increment_column] [-N new_column_name]
23              
24             =head1 DESCRIPTION
25              
26             Compute a running sum over a column of data,
27             or of a constant incremented per row,
28             perhaps to generate a cumulative distribution.
29              
30             What to accumulate is specified by C<-c> or C<-C>.
31              
32             The new column is named by the C<-N> argument, defaulting to C.
33              
34             =head1 OPTIONS
35              
36             =over 4
37              
38             =item B<-c> or B<--column> COLUMN
39              
40             Accumulate values from the given COLUMN.
41             No default.
42              
43             =item B<-C> or B<--constant> K
44              
45             Accumulate the given constant K for each row of input.
46             No default.
47              
48             =item B<-I> or B<--initial-value> I
49              
50             Start accumulation at value I.
51             Defaults to zero.
52              
53             =item B<-N> or B<--new-name> N
54              
55             Name the new column N.
56             Defaults to C.
57              
58             =back
59              
60             =for comment
61             begin_standard_fsdb_options
62              
63             This module also supports the standard fsdb options:
64              
65             =over 4
66              
67             =item B<-d>
68              
69             Enable debugging output.
70              
71             =item B<-i> or B<--input> InputSource
72              
73             Read from InputSource, typically a file name, or C<-> for standard input,
74             or (if in Perl) a IO::Handle, Fsdb::IO or Fsdb::BoundedQueue objects.
75              
76             =item B<-o> or B<--output> OutputDestination
77              
78             Write to OutputDestination, typically a file name, or C<-> for standard output,
79             or (if in Perl) a IO::Handle, Fsdb::IO or Fsdb::BoundedQueue objects.
80              
81             =item B<--autorun> or B<--noautorun>
82              
83             By default, programs process automatically,
84             but Fsdb::Filter objects in Perl do not run until you invoke
85             the run() method.
86             The C<--(no)autorun> option controls that behavior within Perl.
87              
88             =item B<--help>
89              
90             Show help.
91              
92             =item B<--man>
93              
94             Show full manual.
95              
96             =back
97              
98             =for comment
99             end_standard_fsdb_options
100              
101              
102             =head1 SAMPLE USAGE
103              
104             =head2 Input:
105              
106             #fsdb diff
107             0.0
108             00.000938
109             00.001611
110             00.001736
111             00.002006
112             00.002049
113             # | /home/johnh/BIN/DB/dbrow
114             # | /home/johnh/BIN/DB/dbcol diff
115             # | dbsort diff
116              
117             =head2 Command:
118              
119             cat DATA/kitrace.fsdb | dbrowaccumulate -c diff
120              
121             =head2 Output:
122              
123             #fsdb diff accum
124             0.0 0
125             00.000938 .000938
126             00.001611 .002549
127             00.001736 .004285
128             00.002006 .006291
129             00.002049 .00834
130             # | /home/johnh/BIN/DB/dbrow
131             # | /home/johnh/BIN/DB/dbcol diff
132             # | dbsort diff
133             # | /home/johnh/BIN/DB/dbrowaccumulate diff
134              
135              
136             =head1 SEE ALSO
137              
138             L,
139             L.
140              
141              
142             =head1 CLASS FUNCTIONS
143              
144             =cut
145              
146             @ISA = qw(Fsdb::Filter);
147             $VERSION = 2.0;
148              
149 1     1   5770 use strict;
  1         2  
  1         31  
150 1     1   5 use Pod::Usage;
  1         1  
  1         101  
151 1     1   6 use Carp;
  1         2  
  1         80  
152              
153 1     1   10 use Fsdb::Filter;
  1         2  
  1         43  
154 1     1   9 use Fsdb::IO::Reader;
  1         3  
  1         31  
155 1     1   4 use Fsdb::IO::Writer;
  1         2  
  1         24  
156 1     1   4 use Fsdb::Support qw($is_numeric_regexp);
  1         2  
  1         717  
157              
158              
159             =head2 new
160              
161             $filter = new Fsdb::Filter::dbrowaccumulate(@arguments);
162              
163             Create a new dbrowaccumulate object, taking command-line arguments.
164              
165             =cut
166              
167             sub new ($@) {
168 0     0 1   my $class = shift @_;
169 0           my $self = $class->SUPER::new(@_);
170 0           bless $self, $class;
171 0           $self->set_defaults;
172 0           $self->parse_options(@_);
173 0           $self->SUPER::post_new();
174 0           return $self;
175             }
176              
177              
178             =head2 set_defaults
179              
180             $filter->set_defaults();
181              
182             Internal: set up defaults.
183              
184             =cut
185              
186             sub set_defaults ($) {
187 0     0 1   my($self) = @_;
188 0           $self->SUPER::set_defaults();
189 0           $self->{_target_column} = undef;
190 0           $self->{_increment} = undef;
191 0           $self->{_destination_column} = 'accum';
192 0           $self->{_initial_value} = 0;
193             }
194              
195             =head2 parse_options
196              
197             $filter->parse_options(@ARGV);
198              
199             Internal: parse command-line arguments.
200              
201             =cut
202              
203             sub parse_options ($@) {
204 0     0 1   my $self = shift @_;
205              
206 0           my(@argv) = @_;
207             $self->get_options(
208             \@argv,
209 0     0     'help|?' => sub { pod2usage(1); },
210 0     0     'man' => sub { pod2usage(-verbose => 2); },
211             'autorun!' => \$self->{_autorun},
212             'c|column=s' => \$self->{_target_column},
213             'C|increment=s' => \$self->{_increment},
214             'close!' => \$self->{_close},
215             'd|debug+' => \$self->{_debug},
216 0     0     'i|input=s' => sub { $self->parse_io_option('input', @_); },
217             'I|initial-value=s' => \$self->{_initial_value},
218             'log!' => \$self->{_logprog},
219             'N|new-name=s' => \$self->{_destination_column},
220 0     0     'o|output=s' => sub { $self->parse_io_option('output', @_); },
221 0 0         ) or pod2usage(2);
222 0           push (@{$self->{_argv}}, @argv);
  0            
223             }
224              
225             =head2 setup
226              
227             $filter->setup();
228              
229             Internal: setup, parse headers.
230              
231             =cut
232              
233             sub setup ($) {
234 0     0 1   my($self) = @_;
235              
236             croak $self->{_prog} . ": neither -c nor -C specified, so nothing to accumulate.\n"
237 0 0 0       if (!(defined($self->{_target_column}) || defined($self->{_increment})));
238             croak $self->{_prog} . ": both -c nor -C specified, but can't double accumulate.\n"
239 0 0 0       if (defined($self->{_target_column}) && defined($self->{_increment}));
240              
241 0           $self->finish_io_option('input', -comment_handler => $self->create_pass_comments_sub);
242              
243 0 0         if (defined($self->{_target_column})) {
244 0           $self->{_target_coli} = $self->{_in}->col_to_i($self->{_target_column});
245             croak $self->{_prog} . ": target column " . $self->{_target_column} . " is not in input stream.\n"
246 0 0         if (!defined($self->{_target_coli}));
247             };
248              
249             # early error detection
250             croak $self->{_prog} . ": invalid, non-numeric increment '" . $self->{_increment} . "'\n"
251 0 0 0       if (defined($self->{_increment}) && $self->{_increment} !~ /$is_numeric_regexp/);
252             croak $self->{_prog} . ": invalid, non-numeric initial value '" . $self->{_initial_value} . "'\n"
253 0 0         if ($self->{_initial_value} !~ /$is_numeric_regexp/);
254            
255 0           $self->finish_io_option('output', -clone => $self->{_in}, -outputheader => 'delay');
256             $self->{_out}->col_create($self->{_destination_column})
257 0 0         or croak $self->{_prog} . ": cannot create column '" . $self->{_destination_column} . "' (maybe it already existed?)\n";
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 0           my $accum_coli = $self->{_out}->col_to_i($self->{_destination_column});
274              
275 0           my $pre_set_x_code = '';
276 0           my $loop_set_x_code = '';
277 0 0         if (defined($self->{_target_coli})) {
    0          
278 0           $loop_set_x_code = '$x = $fref->[' . $self->{_target_coli} . '];' .
279             '$x = 0 if ($x !~ /$is_numeric_regexp/);';
280             } elsif (defined($self->{_increment})) {
281             # already sanity checked
282 0           $pre_set_x_code = '$x = ' . $self->{_increment} . ';';
283             } else {
284 0           die "internal error";
285             };
286              
287 0 0         my $initial_accum = defined($self->{_initial_value}) ? $self->{_initial_value} + 0 : 0;
288 0           my $loop_sub;
289 0           my $loop_sub_code = '$loop_sub = sub {
290             my $fref;
291             my $accum = $initial_accum;
292             my $x;
293             ' . $pre_set_x_code . '
294             while ($fref = &$read_fastpath_sub()) {
295             ' . $loop_set_x_code . '
296             $accum += $x;
297             $fref->[' . $accum_coli . '] = $accum;
298             &$write_fastpath_sub($fref);
299             };
300             };';
301 0 0         print STDERR $loop_sub_code if ($self->{_debug});
302 0           eval $loop_sub_code;
303 0 0         $@ && die $self->{_prog} . ": internal eval error: $@.\n";
304 0           &$loop_sub();
305             }
306              
307              
308             =head1 AUTHOR and COPYRIGHT
309              
310             Copyright (C) 1991-2008 by John Heidemann
311              
312             This program is distributed under terms of the GNU general
313             public license, version 2. See the file COPYING
314             with the distribution for details.
315              
316             =cut
317              
318             1;