File Coverage

blib/lib/Fsdb/IO/Writer.pm
Criterion Covered Total %
statement 12 160 7.5
branch 0 90 0.0
condition 0 32 0.0
subroutine 4 24 16.6
pod 14 14 100.0
total 30 320 9.3


line stmt bran cond sub pod time code
1             #!/usr/bin/perl -w
2              
3             #
4             # Fsdb::IO::Writer.pm
5             # $Id: fd415a455a6624afba5caf36461747a81c2d0186 $
6             #
7             # Copyright (C) 2005-2013 by John Heidemann
8             #
9             # This program is free software; you can redistribute it and/or
10             # modify it under the terms of the GNU General Public License,
11             # version 2, as published by the Free Software Foundation.
12             #
13             # This program is distributed in the hope that it will be useful,
14             # but WITHOUT ANY WARRANTY; without even the implied warranty of
15             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16             # GNU General Public License for more details.
17             #
18             # You should have received a copy of the GNU General Public License along
19             # with this program; if not, write to the Free Software Foundation, Inc.,
20             # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
21             #
22              
23              
24             package Fsdb::IO::Writer;
25              
26             =head1 NAME
27              
28             Fsdb::IO::Writer - handle formatting reading from a fsdb file (handle) or queue
29              
30             =cut
31              
32             @ISA = qw(Fsdb::IO);
33             ($VERSION) = 1.1;
34              
35 2     2   11 use strict;
  2         3  
  2         64  
36 2     2   8 use IO::File;
  2         3  
  2         304  
37 2     2   10 use Carp;
  2         2  
  2         133  
38              
39             # do these only when needed:
40             # use IO::Compress::Bzip2;
41             # use IO::Compress::Gzip;
42             # use IO::Compress::Xz;
43              
44 2     2   10 use Fsdb::IO;
  2         3  
  2         4577  
45              
46              
47             =head2 new
48              
49             $fsdb = new Fsdb::IO::Writer(-file => $filename);
50             $fsdb = new Fsdb::IO::Writer(-header => "#fsdb -F t foo bar",
51             -fh => $file_handle);
52             $fsdb = new Fsdb::IO::Writer(-file => '-',
53             -fscode => 'S',
54             -cols => [qw(firstcol second)]);
55              
56             Creates a new writer object.
57             Always succeeds, but
58             check the C method to test for failure.
59              
60             Options:
61              
62             =over 4
63              
64             =item other options
65             See also the options in Fsdb::IO, including
66             C<-file>, C<-header>.
67              
68             =item -file FILENAME
69             Open and write the given filename.
70              
71             =item -outputheader [now|delay|never|&format_sub]
72              
73             If value is "now" (the default), the header is generated after option parsing.
74             If "delay", it is generated on first data record output.
75             If "never", no header is ever output, and output will then not be fsdb format.
76             If it is a perl subroutine, then the C is called
77             to generate the header on the first data record output (like delay);
78             it should return the string for the header.
79              
80             =back
81              
82             =cut
83              
84             sub new {
85 0     0 1   my $class = shift @_;
86 0           my $self = $class->SUPER::new(@_);
87 0           bless $self, $class;
88             #
89             # new instance variables
90 0     0     $self->{_write_rowobj_sub} = sub { croak "Fsdb::IO::Writer: attempt to write to unprepared stream\n"; }; # placeholder
  0            
91 0           $self->{_autoflush} = 0;
92             #
93 0           $self->config(@_);
94 0 0         return $self if ($self->{_error});
95             #
96             # setup:
97 0 0 0       if (! ($self->{_fh} || $self->{_queue})) {
98 0           $self->{_error} = "failed to set up output stream";
99 0           return $self;
100             };
101 0 0 0       if ($self->{_fh} && ref($self->{_fh}) eq 'IO::Pipe') {
102             # don't do this if we're IO::Pipe::End, since it's already been done
103 0           $self->{_fh}->writer();
104             };
105 0 0 0       if ($self->{_fh} && $self->{_autoflush}) {
106 0           $self->{_fh}->autoflush(1);
107             };
108             # Default to agressively generating header.
109             # Call it for never (!) so we call create_io_subs.
110 0 0         $self->{_outputheader} = 'now' if (!defined($self->{_outputheader}));
111 0 0 0       $self->write_headerrow unless (ref($self->{_outputheader}) eq 'CODE' || $self->{_outputheader} eq 'delay');
112              
113 0           return $self;
114             }
115              
116             =head2 config_one
117              
118             documented in new
119              
120             =cut
121             sub config_one {
122 0     0 1   my($self, $aaref) = @_;
123 0 0         if ($aaref->[0] eq '-file') {
    0          
    0          
124 0           shift @$aaref;
125 0           my($file) = shift @$aaref;
126 0           my $fh;
127 0           my $mode = $self->default_binmode();
128 0 0         if ($file eq '-') {
129 0           $fh = new IO::Handle;
130 0           $fh->fdopen(fileno(STDOUT),">");
131 0           binmode $fh, $mode;
132             } else {
133 0           $fh = new IO::File $file, ">$mode";
134             };
135 0 0         if ($fh) {
136 0           $self->{_fh} = $fh;
137             } else {
138 0           $self->{_error} = "cannot open $file";
139             };
140             } elsif ($aaref->[0] eq '-autoflush') {
141 0           shift @$aaref;
142 0           my $af = shift @$aaref;
143 0   0       $af //= 0;
144 0           $self->{_autoflush} = $af;
145 0 0 0       croak "autoflush must be 0 or undef, or 1.\n"
146             if (!($af == 0 || $af == 1));
147             } elsif ($aaref->[0] eq '-outputheader') {
148 0           shift @$aaref;
149 0           my $oh = shift @$aaref;
150 0           $self->{_outputheader} = $oh;
151 0 0 0       croak "outputheader must be now, delay, never, or a sub.\n"
152             if (!(ref($oh) eq 'CODE' || $oh eq 'now' || $oh eq 'delay' || $oh eq 'never'));
153             } else {
154 0           $self->SUPER::config_one($aaref);
155             };
156             }
157              
158             =head2 _enable_compression
159              
160             $self->_enable_compression
161              
162             internal use only: switch from uncompressed to compressed.
163              
164             =cut
165             sub _enable_compression($) {
166 0     0     my($self) = @_;
167 0 0         return if (!$self->{_compression});
168              
169 0           my $phy_fh = $self->{_fh};
170 0           $phy_fh->flush;
171 0           binmode($phy_fh, ":raw");
172 0           my $cooked_fh = undef;
173 0 0         if ($self->{_compression} eq 'gz') {
    0          
    0          
174 0           require IO::Compress::Gzip;
175             # We use "Minimal" on next line, otherwise
176             # we get a timestamp in the output,
177             # making output non-repeatable.
178 0           $cooked_fh = new IO::Compress::Gzip($phy_fh, time => 0, minimal => 1);
179             } elsif ($self->{_compression} eq 'xz') {
180 0           require IO::Compress::Xz;
181 0           $cooked_fh = new IO::Compress::Xz $phy_fh;
182             } elsif ($self->{_compression} eq 'bz2') {
183 0           require IO::Compress::Bzip2;
184 0           $cooked_fh = new IO::Compress::Bzip2 $phy_fh;
185             } else {
186 0           croak "Fsbb::IO::Writer:_enable_compression: unknown compression type.\n";
187             };
188 0 0         $cooked_fh or croak "Fsdb::IO::Reader: cannot switch to compression " . $self->{_compression};
189 0           $self->{_fh} = $cooked_fh;
190             # xxx: we now should push our encoding onto this new fh,
191             # but not clear how IO::Uncompress handles that.
192             }
193              
194              
195             =head2 create_io_subs
196              
197             $self->create_io_subs($with_compression)
198              
199             internal use only: create a thunk that writes rowobjs.
200              
201             =cut
202             sub create_io_subs() {
203 0     0 1   my($self) = @_;
204 0 0         return if ($self->{_error});
205              
206 0 0 0       croak "confusion: too many IO sinks" if (defined($self->{_fh}) && defined($self->{_queue}));
207 0 0         if (defined($self->{_fh})) {
    0          
208 0 0 0       $self->_enable_compression() if ($self->{_compression} && $self->{_header_set});
209 0 0 0       if ($self->{_rscode} eq 'D') {
    0          
210 0           my $fh = $self->{_fh};
211 0           my $fs = $self->{_fs};
212 0 0         croak "confusion: undefined _fs in Fsdb::IO::Writer::create_io_subs\n" if (!defined($fs));
213             $self->{_write_rowobj_sub} = sub {
214 0     0     my $rowobj = $_[0];
215 0 0         if (ref($rowobj) eq 'ARRAY') {
    0          
    0          
216 0           $fh->print(join($fs, @$rowobj) . "\n");
217             } elsif (!defined($rowobj)) {
218 0           die; # for now, don't allow undef => close
219             } elsif (!ref($rowobj)) {
220             # raw comment
221 0           $fh->print($rowobj);
222             } else {
223 0           die; # should never happen
224             };
225 0           };
226             } elsif ($self->{_rscode} eq 'C' || $self->{_rscode} eq 'I') {
227 0           my $fh = $self->{_fh};
228 0           my $ncols = $#{$self->{_cols}};
  0            
229 0           my $always_print = ($self->{_rscode} eq 'C');
230 0           my $empty = $self->{_empty};
231             $self->{_write_rowobj_sub} = sub {
232 0     0     my $rowobj = $_[0];
233 0 0         if (ref($rowobj) eq 'ARRAY') {
    0          
    0          
234             # assert(ref($rowobj) eq 'ARRAY');
235 0           foreach (0..$ncols) {
236 0 0 0       $fh->print($self->{_cols}[$_] . ": " . $rowobj->[$_] . "\n")
237             if ($always_print || $rowobj->[$_] ne $empty);
238             };
239 0           $fh->print("\n");
240             } elsif (!defined($rowobj)) {
241 0           die; # for now, don't allow undef => close
242             } elsif (!ref($rowobj)) {
243             # raw comment
244 0           $fh->print($rowobj);
245             } else {
246 0           die;
247             };
248 0           };
249             } else {
250 0           croak "undefined rscode " . $self->{_rscode} . "\n";
251             };
252             } elsif (defined($self->{_queue})) {
253 0           my $queue = $self->{_queue};
254             $self->{_write_rowobj_sub} = sub {
255 0     0     $queue->enqueue(@_);
256 0           };
257             } else {
258 0           croak "confusion: no IO sink\n";
259             };
260             }
261              
262              
263             =head2 write_headerrow
264              
265             internal use only; write the header.
266              
267             As a side-effect, we also instantiate the _write_io_sub.
268              
269             =cut
270             sub write_headerrow() {
271 0     0 1   my($self) = @_;
272 0 0         croak "double header write.\n" if ($self->{_header_set});
273              
274             # Note: reader/writer difference: readers have io subs before headers; writers only after.
275             # We therefore make them here and immediately call them.
276 0           $self->create_io_subs();
277              
278 0 0         return if ($self->{_outputheader} eq 'never');
279             # Note, this is the default path when outputheader eq 'delay'.
280             # generate it
281 0 0         if (ref($self->{_outputheader}) eq 'CODE') {
282 0           $self->{_headerrow} = &{$self->{_outputheader}}($self);
  0            
283             };
284             # write that header!
285             die "internal error: Fsdb::IO::Writer undefined header.\n"
286 0 0         if (!defined($self->{_headerrow}));
287 0           &{$self->{_write_rowobj_sub}}($self->{_headerrow} . "\n");
  0            
288              
289 0           $self->{_header_set} = 1;
290             # switch modes
291 0 0         $self->create_io_subs() if ($self->{_compression});
292             };
293              
294             # =head2 write_attributes
295             #
296             # Write the attributes. Called by interested clients
297             # if they have attributes. Because attributes are I guarnteed
298             # to be presevered across filters, interested clients
299             # must explicitly write them.
300             #
301             # =cut
302             # sub write_attributes {
303             # my($self) = @_;
304             # croak "double attribute write.\n" if ($self->{_attributes_set});
305             # $self->{_attributes_set} = 1;
306             #
307             # foreach my $key (sort keys %{$self->{_attributes}}) {
308             # my $value = $self->{_attributes}{$key};
309             # &{$self->{_write_rowobj_sub}}("#% $key: $value\n");
310             # };
311             # };
312             #
313             # =head2 check_attributes
314             #
315             # internal use only; check that attributes are set.
316             # (for a writer, they always are)
317             #
318             # =cut
319             # sub check_attributes {
320             # }
321             #
322              
323             =head2 write_rowobj
324              
325             $fsdb->write_rowobj($rowobj);
326              
327             Write a "row object" to an outpu stream.
328             Row objects are either a scalar string,
329             for a comment or header,
330             or an array reference for a row.
331             This routine is the fastest way to do full-featured fsdb-formatted IO.
332             (Although see also Fsdb::Writer::fastpath_sub.)
333              
334             =cut
335             sub write_rowobj {
336 0     0 1   my ($self, $rowobj) = @_;
337              
338 0 0         return if (defined($self->{_error}));
339 0 0         $self->write_headerrow unless ($self->{_header_set});
340 0           return &{$self->{_write_rowobj_sub}}($rowobj);
  0            
341             }
342              
343              
344             =head2 write_row_from_aref
345              
346             $fsdb->write_row_from_aref(\@a);
347              
348             Write @a.
349              
350             =cut
351              
352             sub write_row_from_aref {
353 0     0 1   my($self, $aref) = @_;
354              
355 0           $self->write_rowobj($aref);
356             }
357              
358              
359             =head2 write_row
360              
361             $fsdb->write_row($a1, $a2...);
362              
363             Write args out. Less efficient than write_row_from_aref.
364              
365             =cut
366              
367             sub write_row {
368 0     0 1   my($self) = shift @_;
369              
370 0           $self->write_row_from_aref(\@_);
371             }
372              
373             =head2 write_row_from_href
374              
375             $fsdb->write_row_from_href(\%h);
376              
377             Write out %h, a hash of the row fields where each key is a field name.
378              
379             =cut
380              
381             sub write_row_from_href {
382 0     0 1   my($self, $href) = @_;
383              
384 0           my @a;
385 0           foreach (@{$self->{_cols}}) {
  0            
386 0           my $v = $href->{$_};
387 0 0         push(@a, defined($v) ? $v : $self->{_empty});
388             };
389 0           $self->write_row_from_aref(\@a);
390             }
391              
392             =head2 fastpath_ok
393              
394             $fsdb->fastpath_ok();
395              
396             Check if we can do fast-path IO
397             (header written, no errors).
398              
399             =cut
400             sub fastpath_ok {
401 0     0 1   my($self) = @_;
402              
403 0 0         $self->write_headerrow unless ($self->{_header_set});
404 0 0         return undef if (defined($self->{_error}));
405 0           return 1;
406             }
407              
408             =head2 fastpath_sub
409              
410             $fsdb->fastpath_sub()
411              
412             Return an anonymous sub that does fast-path rowobj writes when called.
413              
414             =cut
415             sub fastpath_sub {
416 0     0 1   my($self) = @_;
417              
418 0 0         $self->fastpath_ok or croak "not able to do write fastpath\n";
419 0           $self->{_fastpath_active} = 1;
420             # for writing, just the same as rowobj
421 0           return $self->{_write_rowobj_sub};
422             }
423              
424             =head2 close
425              
426             $fsdb->close;
427              
428             Close the file and kill the saved writer sub.
429              
430             =cut
431              
432             sub close() {
433 0     0 1   my($self) = @_;
434 0     0     $self->{_write_rowobj_sub} = sub { die; };
  0            
435 0           $self->SUPER::close(@_);
436             }
437              
438              
439              
440             =head2 write_comment
441              
442             $fsdb->write_comment($c);
443              
444             Write out $c as a comment.
445             ($c should be just the text, without a "# " header or a newline trailer.
446              
447             =cut
448              
449             sub write_comment {
450 0     0 1   my($self, $c) = @_;
451 0           &{$self->{_write_rowobj_sub}}("# " . $c . "\n");
  0            
452             }
453              
454             =head2 write_raw
455              
456             $fsdb->write_raw($c);
457              
458             Write out $c as raw output,
459             typically because it's a comment that already has a "#" in front
460             and a newline at the rear.
461              
462             =cut
463              
464             sub write_raw {
465 0     0 1   my($self, $c) = @_;
466 0           &{$self->{_write_rowobj_sub}}($c);
  0            
467             }
468              
469              
470             #
471             # hack
472             #
473              
474             =head2 format_fsdb_fields
475              
476             format_fsdb_fields(\%data, \@fields)
477              
478             Returns a string representing double-space-separated, formatted version of
479             the hash'ed fields stored in %data, listed in @fields.
480             (This routine is a hack, there needs to be a FsdbWriter to do this properly,
481             but there isn't currently.
482              
483             =cut
484              
485             sub format_fsdb_fields {
486 0     0 1   my($data_href, $fields_aref) = @_;
487 0           my $out = '';
488 0           foreach (@$fields_aref) {
489 0 0         my $val = defined($data_href->{$_}) ? $data_href->{$_} : '-';
490 0           $val =~ s/\n/\\n/g; # fix newlines
491 0           $val =~ s/ +/ /g; # fix double spaces
492 0           $out .= $val . " ";
493             };
494 0           $out =~ s/ $//; # trim trailing spaces
495 0           return $out;
496             }
497              
498              
499             1;