File Coverage

blib/lib/Fsdb/Filter/dbcolneaten.pm
Criterion Covered Total %
statement 21 112 18.7
branch 0 32 0.0
condition 0 12 0.0
subroutine 7 21 33.3
pod 6 6 100.0
total 34 183 18.5


line stmt bran cond sub pod time code
1             #!/usr/bin/perl -w
2              
3             #
4             # dbcolneaten.pm
5             # Copyright (C) 1991-2015 by John Heidemann
6             # $Id: 08aa35fa94fdc4d03a4df698dd6cad51ed924281 $
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::dbcolneaten;
14              
15             =head1 NAME
16              
17             dbcolneaten - pretty-print columns of Fsdb data (assuming a monospaced font)
18              
19             =head1 SYNOPSIS
20              
21             dbcolneaten [-E] [field_settings]
22              
23             =head1 DESCRIPTION
24              
25             L arranges that the Fsdb data appears in
26             neat columns if you view it with a monospaced font.
27             To do this, it pads out each field with spaces to line up
28             the next field.
29              
30             Field settings are of the form
31              
32             field op value
33              
34             OP is >=, =, or <= specifying that the width of
35             that FIELD must be more, equal, or less than that VALUE
36              
37              
38             L runs in O(1) memory but disk space proportional to the
39             size of data.
40              
41             =head1 OPTIONS
42              
43             =over 4
44              
45             =item B<-E> or B<--noeoln>
46              
47             Omit padding for the last column (at the end-of-the-line).
48             (Default behavior.)
49              
50             =item B<-e> or B<--eoln>
51              
52             Do padding and include an extra field separator after the last column.
53             (Useful if you're interactively adding a column.)
54              
55             =back
56              
57             =for comment
58             begin_standard_fsdb_options
59              
60             This module also supports the standard fsdb options:
61              
62             =over 4
63              
64             =item B<-d>
65              
66             Enable debugging output.
67              
68             =item B<-i> or B<--input> InputSource
69              
70             Read from InputSource, typically a file name, or C<-> for standard input,
71             or (if in Perl) a IO::Handle, Fsdb::IO or Fsdb::BoundedQueue objects.
72              
73             =item B<-o> or B<--output> OutputDestination
74              
75             Write to OutputDestination, typically a file name, or C<-> for standard output,
76             or (if in Perl) a IO::Handle, Fsdb::IO or Fsdb::BoundedQueue objects.
77              
78             =item B<--autorun> or B<--noautorun>
79              
80             By default, programs process automatically,
81             but Fsdb::Filter objects in Perl do not run until you invoke
82             the run() method.
83             The C<--(no)autorun> option controls that behavior within Perl.
84              
85             =item B<--help>
86              
87             Show help.
88              
89             =item B<--man>
90              
91             Show full manual.
92              
93             =back
94              
95             =for comment
96             end_standard_fsdb_options
97              
98              
99             =head1 SAMPLE USAGE
100              
101             =head2 Input:
102              
103             #fsdb fullname homedir uid gid
104             Mr._John_Heidemann_Junior /home/johnh 2274 134
105             Greg_Johnson /home/greg 2275 134
106             Root /root 0 0
107             # this is a simple database
108             # | dbcol fullname homedir uid gid
109              
110             =head2 Command:
111              
112             dbcolneaten
113              
114             =head2 Output:
115              
116             #fsdb -F s fullname homedir uid gid
117             Mr._John_Heidemann_Junior /home/johnh 2274 134
118             Greg_Johnson /home/greg 2275 134
119             Root /root 0 0
120             # this is a simple database
121             # | dbcol fullname homedir uid gid
122             # | dbcolneaten
123              
124              
125             =head1 BUGS
126              
127             Does not handle tab separators correctly.
128              
129              
130             =head1 SEE ALSO
131              
132             L.
133              
134              
135             =head1 CLASS FUNCTIONS
136              
137             =cut
138              
139             @ISA = qw(Fsdb::Filter);
140             ($VERSION) = 2.0;
141              
142 1     1   22600 use strict;
  1         3  
  1         38  
143 1     1   7 use Pod::Usage;
  1         3  
  1         127  
144 1     1   8 use Carp;
  1         3  
  1         68  
145              
146 1     1   6 use Fsdb::Filter;
  1         3  
  1         24  
147 1     1   6 use Fsdb::IO::Reader;
  1         3  
  1         24  
148 1     1   5 use Fsdb::IO::Writer;
  1         3  
  1         26  
149 1     1   7 use Fsdb::IO::Replayable;
  1         3  
  1         1528  
150              
151              
152             =head2 new
153              
154             $filter = new Fsdb::Filter::dbcolneaten(@arguments);
155              
156             Create a new dbcolneaten object, taking command-line arguments.
157              
158             =cut
159              
160             sub new ($@) {
161 0     0 1   my $class = shift @_;
162 0           my $self = $class->SUPER::new(@_);
163 0           bless $self, $class;
164 0           $self->set_defaults;
165 0           $self->parse_options(@_);
166 0           $self->SUPER::post_new();
167 0           return $self;
168             }
169              
170              
171             =head2 set_defaults
172              
173             $filter->set_defaults();
174              
175             Internal: set up defaults.
176              
177             =cut
178              
179             sub set_defaults ($) {
180 0     0 1   my($self) = @_;
181 0           $self->SUPER::set_defaults();
182 0           $self->{_do_eoln} = 0;
183 0           $self->{_field_specs} = [];
184             }
185              
186             =head2 parse_options
187              
188             $filter->parse_options(@ARGV);
189              
190             Internal: parse command-line arguments.
191              
192             =cut
193              
194             sub parse_options ($@) {
195 0     0 1   my $self = shift @_;
196              
197 0           my(@argv) = @_;
198             $self->get_options(
199             \@argv,
200 0     0     'help|?' => sub { pod2usage(1); },
201 0     0     'man' => sub { pod2usage(-verbose => 2); },
202             'autorun!' => \$self->{_autorun},
203             'close!' => \$self->{_close},
204             'd|debug+' => \$self->{_debug},
205             'eoln!' => \$self->{_do_eoln},
206 0     0     'e' => sub { $self->{_do_eoln} = 1; },
207 0     0     'E' => sub { $self->{_do_eoln} = 0; },
208 0     0     'i|input=s' => sub { $self->parse_io_option('input', @_); },
209             'log!' => \$self->{_logprog},
210 0     0     'o|output=s' => sub { $self->parse_io_option('output', @_); },
211 0 0         ) or pod2usage(2);
212 0           push (@{$self->{_field_specs}}, @argv);
  0            
213             }
214              
215             =head2 setup
216              
217             $filter->setup();
218              
219             Internal: setup, parse headers.
220              
221             =cut
222              
223             sub setup ($) {
224 0     0 1   my($self) = @_;
225              
226 0           $self->finish_io_option('input', -comment_handler => $self->create_pass_comments_sub('_replayable_writer'));
227              
228 0           my @change_fscode;
229 0 0         push (@change_fscode, -fscode => 's') if ($self->{_in}->fscode eq 'D');
230             $self->finish_io_option('output', -clone => $self->{_in}, @change_fscode,
231 0     0     -outputheader => sub { $self->format_header(@_) } );
  0            
232              
233 0           $self->{_replayable} = new Fsdb::IO::Replayable(-writer_args => [ -clone => $self->{_in} ], -reader_args => [ -comment_handler => $self->create_pass_comments_sub ]);
234 0           $self->{_replayable_writer} = $self->{_replayable}->writer;
235             }
236              
237             =head2 format_header
238              
239             $filter->format_header($out)
240              
241             Format the header for the current object to output stream C<$out>.
242              
243             =cut
244             sub format_header ($) {
245 0     0 1   my($self, $out) = @_;
246              
247 0 0         croak if ($self->{_out} != $out); # assert
248              
249             # Write out a comment that shows the header fields.
250             # get Fsdb::IO to generate the prequel
251 0           $out->update_headerrow;
252 0           my @cols = @{$out->cols};
  0            
253 0           $cols[0] = $out->{_header_prequel} . $cols[0];
254 0           my $pad = $self->{_pad_fn};
255             # Since we're writing the header, we need to be picky about the fs we use.
256             # see test case dbcolneaten_strange_sep.cmd
257 0           my $header_fs = $out->{_fs};
258 0 0         $header_fs = ' ' if ($header_fs !~ /^\s+$/); # Fall back on benign space if the data uses something fancy.
259 0           &$pad(\@cols, $self->{_colwidths}, $header_fs);
260 0           my $padded_header = join('', @cols);
261              
262             # Sigh, debugging no longer works because we return the result so fastpath is not done yet. Fortunately, no bugs remain.
263             # if ($self->{_debug}) {
264             # my(@debug_colwidths) = @{$self->{_colwidths}};
265             # $debug_colwidths[0] = "# ". $debug_colwidths[0];
266             # &$pad(\@debug_colwidths, $self->{_colwidths}, $self->{_out}->{_fs});
267             # my $padded_debug = join('', @debug_colwidths, "\n");
268             # &$write_fastpath_sub($padded_debug);
269             # };
270              
271 0           return $padded_header;
272             }
273              
274             =head2 run
275              
276             $filter->run();
277              
278             Scan the data once,
279             then rewrite it neatly.
280              
281             =cut
282             sub run ($) {
283 0     0 1   my($self) = @_;
284              
285             #
286             # first, scan the data to find widths
287             #
288 0           my $read_fastpath_sub = $self->{_in}->fastpath_sub();
289 0           my $replayable_writer_fastpath_sub = $self->{_replayable_writer}->fastpath_sub();
290 0           my $fref;
291 0           my @colwidths = (0) x $self->{_in}->ncols;
292 0           while ($fref = &$read_fastpath_sub()) {
293 0           foreach (0..$#colwidths) {
294 0 0         my $l = defined($fref->[$_]) ? length($fref->[$_]) : 0;
295 0 0         $colwidths[$_] = $l if ($l > $colwidths[$_]);
296             };
297 0           &$replayable_writer_fastpath_sub($fref);
298             };
299 0           $self->{_replayable}->close;
300              
301             #
302             # handle arguments
303             # (Sigh, we'd prefer to handle these in setup,
304             # but we also don't want to duplicate the code.)
305             #
306 0           foreach (@{$self->{_field_specs}}) {
  0            
307 0           my($field_name, $op, $value) = m/([^<>=]*)\s*([<>=]+)\s*(\d+)/;
308 0 0 0       croak $self->{_prog} . ": unknown field specification.\n"
309             if (!defined($field_name) || !defined($value));
310 0           my($field_col) = $self->{_in}->col_to_i($field_name);
311 0 0         die ($self->{_prog} . ": unknown column ``$field_name''.\n")
312             if (!defined($field_col));
313 0 0         if ($op eq '=') {
    0          
    0          
314 0           $colwidths[$field_col] = $value;
315             } elsif ($op eq '>=') {
316 0 0         $colwidths[$field_col] = $value if ($colwidths[$field_col] < $value);
317             } elsif ($op eq '<=') {
318 0 0         $colwidths[$field_col] = $value if ($colwidths[$field_col] > $value);
319             } else {
320 0           die $self->{_prog} . ": bad operation $op in field spec $_.\n";
321             };
322             }
323              
324 0           my $fs_width = length($self->{_in}->{_fs});
325 0           my $empty_width = length($self->{_empty});
326 0           my $do_eoln = $self->{_do_eoln};
327             # pad: pad out @$fields_ref to match @$colwidthref spacing per field
328             my $pad = sub {
329 0     0     my($fields_ref, $colwidthref, $extra_char) = @_;
330 0           my $running_place = 0;
331 0           my $running_target = 0;
332 0           foreach (0..$#{$colwidthref}) {
  0            
333 0 0         my $this_col_width = defined($fields_ref->[$_]) ? length($fields_ref->[$_]) : $empty_width;
334 0           $running_place += $this_col_width;
335 0           $running_target += $colwidthref->[$_];
336 0           my $more = $running_target - $running_place;
337 0 0 0       if ($more > 0 && ($_ < $#{$colwidthref} || $do_eoln)) {
      0        
338 0           $fields_ref->[$_] .= (" " x $more);
339 0           $running_place += $more;
340             };
341             # add on field sep for comments
342             # (only used for the first #fsdb line)
343 0 0 0       $fields_ref->[$_] .= $extra_char if (defined($extra_char) && $_ != $#{$colwidthref});
  0            
344             };
345 0           };
346             # save aside what we'll need in $self->format_header
347 0           $self->{_colwidths} = \@colwidths;
348 0           $self->{_pad_fn} = $pad;
349              
350             #
351             # output:
352             #
353 0           my $replayable_reader = $self->{_replayable}->reader;
354 0           my $replayable_reader_fastpath_sub = $replayable_reader->fastpath_sub();
355             # the next line will callback format_header as a side effect
356 0           my $write_fastpath_sub = $self->{_out}->fastpath_sub();
357              
358             # now, rewrite the data
359 0           while ($fref = &$replayable_reader_fastpath_sub()) {
360 0           &$pad($fref, \@colwidths, undef);
361 0           &$write_fastpath_sub($fref);
362             };
363 0           $replayable_reader->close;
364             }
365              
366              
367             =head1 AUTHOR and COPYRIGHT
368              
369             Copyright (C) 1991-2015 by John Heidemann
370              
371             This program is distributed under terms of the GNU general
372             public license, version 2. See the file COPYING
373             with the distribution for details.
374              
375             =cut
376              
377             1;