File Coverage

blib/lib/Mnet/Report/Table.pm
Criterion Covered Total %
statement 113 311 36.3
branch 41 132 31.0
condition 15 107 14.0
subroutine 14 24 58.3
pod 3 3 100.0
total 186 577 32.2


line stmt bran cond sub pod time code
1             package Mnet::Report::Table;
2              
3             =head1 NAME
4              
5             Mnet::Report::Table - Output rows of report data
6              
7             =head1 SYNOPSIS
8              
9             # create an example new table object, with csv file output
10             my $table = Mnet::Report::Table->new({
11             columns => [
12             device => "string",
13             time => "time",
14             data => "integer",
15             error => "error",
16             ],
17             output => "csv:file.csv",
18             });
19              
20             # output error row if script aborts with unreported errors
21             $table->row_on_error({ device => $device });
22              
23             # output a normal report row, call again to output more
24             $table->row({ device => $device, data => $data });
25              
26             =head1 DESCRIPTION
27              
28             Mnet::Report::Table can be used to create new report table objects, with a row
29             method call to add data, a row_on_error method to ensure errors always appear,
30             with various output options including csv, json, sql, and perl L
31             formats.
32              
33             =head1 METHODS
34              
35             Mnet::Report::Table implements the methods listed below.
36              
37             =cut
38              
39             # required modules
40 1     1   649 use warnings;
  1         7  
  1         32  
41 1     1   5 use strict;
  1         1  
  1         39  
42 1     1   486 use parent qw( Mnet::Log::Conditional );
  1         354  
  1         5  
43 1     1   42 use Carp;
  1         2  
  1         47  
44 1     1   5 use Mnet;
  1         2  
  1         25  
45 1     1   395 use Mnet::Dump;
  1         3  
  1         34  
46 1     1   8 use Mnet::Log::Conditional qw( DEBUG INFO WARN FATAL NOTICE );
  1         2  
  1         61  
47 1     1   6 use Mnet::Opts::Cli::Cache;
  1         2  
  1         155  
48              
49             # init autoflush, global variables, and sig handlers
50             # autoflush is set so multi-process syswrite lines don't clobber each other
51             # @selves tracks report objects until deferred/row_on_error output end block
52             # $error and sig handlers used to track first error, if Mnet::Log not loaded
53             BEGIN {
54 1     1   5 $| = 1;
55 1         3 my @selves = ();
56 1         2 my $error = undef;
57 1 50       4 if (not $INC{'Mnet/Log.pm'}) {
58             $SIG{__DIE__} = sub {
59 11 100       367 if (not defined $Mnet::Report::Table::error) {
60 1         5 chomp($Mnet::Report::Table::error = "@_");
61             }
62 11         62 die @_;
63 1         6 };
64             $SIG{__WARN__} = sub {
65 0 0       0 if (not defined $Mnet::Report::Table::error) {
66 0         0 chomp($Mnet::Report::Table::error = "@_");
67             }
68             warn @_
69 1         3580 };
  0         0  
70             }
71             }
72              
73              
74              
75             sub new {
76              
77             =head2 new
78              
79             $table = Mnet::Report::Table->new(\%opts)
80              
81             A new Mnet::Report::Table object can be created with the options showm in
82             the example below:
83              
84             my $table = Mnet::Report::Table->new({
85             columns => [ # ordered column names and types
86             device => "string", # strips eol chars in csv output
87             count => "integer", # +/- integer numbers
88             error => "error", # first error, see row_on_error()
89             time => "time", # time as yyyy/mm/dd hh:mm:ss
90             unix => "epoch", # unix time, see perldoc -f time
91             ],
92             output => "csv:$file", # see this module's OUTPUT section
93             append => $boolean, # set to append output to file
94             log_id => $string, # see perldoc Mnet::Log new method
95             nodefer => $boolean, # set to output rows immediately
96             });
97              
98             The columns option is required, and is an array reference containing an ordered
99             list of hashed column names of type string, integer, error, time, or epoch.
100              
101             Columns of type string and integer are set by the user for new rows using the
102             row method in this module. Columns of type error, time, and epoch are set
103             automatically for each row of output.
104              
105             The output option should be used to specify an output format and filename, as
106             in the example above. Refer to the OUTPUT section below for more information.
107              
108             The append option opens the output file for appending and doesn't write a
109             heading row, Otherwise the default is to overwrite the output file when the
110             new table object is created.
111              
112             The nodefer option can be used so that report data rows are output immediately
113             when the row method is called. Otherwise row data is output when the script
114             exits. This can affect the reporting of errors, refer to the row_on_error
115             method below for more information.
116              
117             Note that new Mnet::Report::Table objects should be created before forking
118             batch children if the L module is being used.
119              
120             Errors are issued for invalid options.
121              
122             =cut
123              
124             # read input class and options hash ref merged with cli options
125 11   33 11 1 5943 my $class = shift // croak("missing class arg");
126 11   50     39 my $opts = Mnet::Opts::Cli::Cache::get(shift // {});
127              
128             # bless new object created from input opts hash
129             # this allows log_id and other Mnet::Log options to be in effect
130             # the following keys start with underscore and are used internally:
131             # _column_error => set if error column is present, for _row_on_error
132             # _column_order => array ref listing column names in sort order
133             # _column_types => hash ref keyed by column names with value as type
134             # _output_rows => list of row hashes, output t end unless nodefer
135             # _output_fh => filehandle for row outputs, opened from new method
136             # _row_on_error => set with row hash to ensure output if any errors
137             # in addition refer to perldoc for input opts and Mnet::Log0->new opts
138 11         17 my $self = $opts;
139 11         20 bless $self, $class;
140 11         17 push @{$Mnet::Report::Table::selves}, $self;
  11         25  
141 11         44 $self->debug("new starting");
142              
143             # abort if we were called before batch fork if Mnet::Batch was loaded
144             # avoids problems with first row method call from new sub to init output
145             # for example: _output_csv batch parent must create file and heading row
146             # we don't want every batch child creating duplicate heading rows
147             croak("new Mnet::Report::Table must be created before Mnet::Batch::fork")
148 11 50 33     25 if $INC{"Mnet/Batch.pm"} and Mnet::Batch::fork_called();
149              
150             # abort if opts columns array ref is not set
151             # create _column_types hash ref and _column_order array ref in new object
152             # croak for invalid column types and error type if Mnet::Log not loaded
153 11 100       310 croak("missing opts input columns key") if not $opts->{columns};
154 10 100       131 croak("invalid opts input columns key") if ref $opts->{columns} ne "ARRAY";
155 9 100       13 croak("missing opts input column data") if not scalar(@{$opts->{columns}});
  9         124  
156 8         21 $self->{_column_types} = {};
157 8         13 $self->{_column_order} = [];
158 8         14 while (@{$opts->{columns}}) {
  22         51  
159 17   66     22 my $column = shift @{$opts->{columns}} // croak("missing column name");
  17         140  
160 16   66     23 my $type = shift @{$opts->{columns}} // croak("missing column type");
  16         133  
161 15 50       38 croak("invalid column name $column") if $column =~ /["\r\n]/;
162 15         85 $self->debug("new column = $column ($type)");
163 15         33 $self->{_column_types}->{$column} = $type;
164 15         17 push @{$self->{_column_order}}, $column;
  15         27  
165 15 100       31 $self->{_column_error} = 1 if $type eq "error";
166 15 100       61 if ($type !~ /^(epoch|error|integer|string|time)$/) {
167 1         108 croak("column type $type is invalid");
168             }
169             }
170              
171             # debug calls to display output option set for this object
172 5         20 $self->debug("new output = ".Mnet::Dump::line($self->{output}));
173              
174             # call _output method with no row arg to init output
175             # allows batch parent or non-batch proc to open file and output headings
176 5         15 $self->debug("new init _output call");
177 5         11 $self->_output;
178              
179             # finished new method, return Mnet::Report::Table object
180 4         18 $self->debug("new finished, returning $self");
181 4         10 return $self;
182             }
183              
184              
185              
186             sub row {
187              
188             =head2 row
189              
190             $table->row(\%data)
191              
192             This method will add a row of specified data to the current report table
193             object, as in the following example:
194              
195             $table->row({
196             device => $string,
197             sample => $integer,
198             })
199              
200             Note that an error is issued if any keys in the data were not defined as string
201             or integer columns when the new method was used to create the current object.
202              
203             =cut
204              
205             # read input object
206 4   33 4 1 22 my $self = shift // croak("missing self arg");
207 4   66     136 my $data = shift // croak("missing data arg");
208              
209             # init hash ref to hold output row data
210 3         10 my $row = $self->_row_data($data);
211              
212             # output or store row data
213 0 0       0 if ($self->{nodefer}) {
214 0         0 $self->_output($row);
215             } else {
216 0         0 push @{$self->{_output_rows}}, $row;
  0         0  
217             }
218              
219             # finished row method
220 0         0 return;
221             }
222              
223              
224              
225             sub _row_data {
226              
227             # \%row = $self->_row_data(\%data)
228             # purpose: set keys in output row hash form input data hash, with error refs
229              
230             # read input object
231 3   50 3   6 my $self = shift // die "missing self arg";
232 3   50     9 my $data = shift // die "missing data arg";
233 3         9 $self->debug("_row_data starting");
234              
235             # init hash ref to hold output row data
236 3         5 my $row = {};
237              
238             # loop through all columns in the current object
239 3         7 foreach my $column (sort keys %{$self->{_column_types}}) {
  3         14  
240 6         11 my $type = $self->{_column_types}->{$column};
241 6         10 my $value = $data->{$column};
242              
243             # set epoch column to unix time, refer to perldoc -f time
244             # on most systems is non-leap seconds since 00:00:00 jan 1, 1970 utc
245             # this is simplest way to agnostically store time for various uses
246 6 50       20 if ($type eq "epoch") {
    100          
    100          
    50          
    50          
247 0         0 $row->{$column} = time;
248 0 0       0 $row->{$column} = Mnet::Test::time() if $INC{'Mnet/Test.pm'};
249 0 0       0 croak("invalid time column $column") if exists $data->{$column};
250              
251             # set error column type as reference to global first error variable
252             # update global error ref, so all rows show errors from end block
253             # croak if the user supplied data for an error column
254             } elsif ($type eq "error") {
255 3         7 $row->{$column} = \$Mnet::Report::Table::error;
256 3 100       97 croak("invalid error column $column") if exists $data->{$column};
257              
258             # set integer column type, croak on bad integer
259             } elsif ($type eq "integer") {
260 2 100       6 if (defined $value) {
261 1         5 $value =~ s/(^\s+|\s+$)//;
262 1 50       6 if ($value =~ /^(\+|\-)?\d+$/) {
263 0         0 $row->{$column} = $value;
264             } else {
265 1         5 $value = Mnet::Dump::line($value);
266 1         95 croak("invalid integer column $column value $value");
267             }
268             }
269              
270             # set string column type
271             } elsif ($type eq "string") {
272 0         0 $row->{$column} = $value;
273              
274             # set time column types to yyyy/mm/dd hh:mm:ss
275             } elsif ($type eq "time") {
276 1         6 my $time = time;
277 1 50       3 $time = Mnet::Test::time() if $INC{'Mnet/Test.pm'};
278 1         75 my ($sec, $min, $hour, $date, $month, $year) = localtime($time);
279 1         5 $month++; $year += 1900;
  1         3  
280 1         5 my @fields = ($year, $month, $date, $hour, $min, $sec);
281 1         8 $row->{$column} = sprintf("%04s/%02s/%02s %02s:%02s:%02s", @fields);
282 1 50       109 croak("invalid time column $column") if exists $data->{$column};
283              
284             # abort on unknown column type
285             } else {
286 0         0 die "invalid column type $type";
287             }
288              
289             # continue loop through columns in the currect object
290             }
291              
292             # croak if any input data columns were not declared for current object
293 0         0 foreach my $column (sort keys %$data) {
294 0 0       0 next if exists $self->{_column_types}->{$column};
295 0         0 croak("column $column was not defined for $self->{output}");
296             }
297              
298             # finished row method, return row hash ref
299 0         0 $self->debug("_row_data finished");
300 0         0 return $row;
301             }
302              
303              
304              
305             sub row_on_error {
306              
307             =head2 row_on_error
308              
309             $table->row_on_error(\%data)
310              
311             This method can be used to ensure that an Mnet::Report::Table object with an
312             error column outputs an error row when the script exits if no prior output row
313             reflected that there was an error, as in the example below:
314              
315             # declare report object as a global
316             use Mnet::Report::Table;
317             my $table = Mnet::Report::Table->new({
318             output => "json:file.json",
319             columns => [
320             input => "text",
321             error => "error",
322             ttl => "integer"
323             ],
324             });
325              
326             # call Mnet::Batch::fork here, if using Mnet::Batch module
327              
328             # output error row at exit if there was an unreported error
329             $table->row_on_error({ input => "error" });
330              
331             # output first row, no error, always present in output
332             $table->row({ input => "first" });
333              
334             # lots of code could go here, with possibility of errors...
335             die if int(rand) > .5;
336              
337             # output second row, no error, present if die did not occur
338             $table->row({ input => "second" });
339              
340             # row_on_error output at exit for unpreported errors
341             exit;
342              
343             This ensures that a script does not die after the row_on_error call without
344             any indication of an error in the report output.
345              
346             The default is to output all report data rows when the script exits. At this
347             time all error columns for all rows will be set with the first of any prior
348             script errors. In this case row_on_error will output an error row if there
349             was an error and the row method was never called.
350              
351             If the nodefer option was set when a new Mnet::Report::Table object was created
352             then row data is output immediately each time the row method is called, with
353             the error column set only if there was an error before the row method call. Any
354             errors afterward could go unreported. In this case row_on_error will output an
355             extra row at script exit if there was an error after the last row method call,
356             or the row method was never called.
357              
358             =cut
359              
360             # read inputs, store row_on_error row data as object _row_on_error
361             # this is output from module end block if there were unreported errors
362 0   0 0 1 0 my $self = shift // croak("missing self arg");
363 0   0     0 my $data = shift // croak("missing data arg");
364 0 0       0 croak("row_on_error requires error column") if not $self->{_column_error};
365 0         0 $self->{_row_on_error} = $self->_row_data($data);
366 0         0 return;
367             }
368              
369              
370              
371             =head1 OUTPUT OPTIONS
372              
373             When a new Mnet::Report::Table object is created the output option can be set
374             to any of the output format types listed in the documentation sections below.
375              
376             If the L module is loaded report rows are always logged with the
377             info method.
378              
379             Note the L module --test command line option silently overrides all
380             other report output options, outputting report data using the L
381             module if loaded or sending report output to stdout in L format,
382             for consistant test results.
383              
384             Output files are opened when an Mnet::Report object is created, with a heading
385             row if necessary. Refer to the new method in this documentation for information
386             on the append and nodefer options that control how the output file is opened
387             and when row data is written.
388              
389             Output options below can use /dev/stdout as the output file, which works nicely
390             with the L --silent option used with the L --batch
391             option, allowing report output from all concurrently executing batch children
392             to be easily piped or redirected in aggregate as necessary. However be aware
393             thet /dev/stdout report output is not captured by the L module.
394              
395             Note the L module --test command line option silently overrides
396             all other report output options, outputting report data using the L
397             module if loaded or sending report output to stdout in L format,
398             for consistant test results.
399              
400             =cut
401              
402             sub _output {
403              
404             # $self->_output(\$row)
405             # purpose: called from new to open file and output headings, called from row
406             # \%row: row data, or undef for init call from new method w/Mnet::Batch loaded
407             # $self->{output} object property is parsed to determin output type
408             # $self->{append} clear by default, output overwrites file, heading rows output
409             # $self->{append} set will append to output file, headng rows are suppressed
410              
411             # read input object and row data hash reference
412 5   50 5   17 my $self = shift // die "missing self arg";
413 5         8 my $row = shift;
414 5         27 $self->debug("_output starting");
415              
416             # init file parsed from output option and row output line
417 5         33 my ($file, $output) = (undef, undef);
418              
419             # handle --test output, skipped for undef heading row
420 5         15 my $cli = Mnet::Opts::Cli::Cache::get({});
421 5 50       25 if ($cli->{test}) {
422 0 0       0 if (defined $row) {
423 0         0 $self->debug("_output calling _output_test");
424 0         0 $output = $self->_output_test($row);
425             }
426              
427             # handle non-test output
428             } else {
429              
430             # log report row output, skipped for undef heading row
431 5 50       13 if (defined $row) {
432 0         0 $self->debug("_output calling _output_log");
433 0         0 $output = $self->_output_log($row);
434             }
435              
436             # note that no output option was set
437 5 100       28 if (not defined $self->{output}) {
    50          
    50          
    50          
    50          
    50          
438 4         23 $self->debug("_output skipped, output option not set");
439              
440             # handle csv output, refer to sub _output_csv
441             } elsif ($self->{output} =~ /^csv(:(.+))?$/) {
442 0         0 $self->debug("_output calling _output_csv");
443 0         0 $output = $self->_output_csv($row);
444 0   0     0 $file = $2 // "/dev/stdout";
445              
446             # handle dump output, call with var name arg, refer to sub _output_dump
447             } elsif ($self->{output} =~ /^dump(:([a-zA-Z]\w*)(:(.+))?)?$/) {
448 0         0 $self->debug("_output calling _output_dump");
449 0   0     0 $output = $self->_output_dump($row, $2 // "dump");
450 0   0     0 $file = $4 // "/dev/stdout";
451              
452             # handle json output, call with var name arg, refer to sub _output_json
453             } elsif ($self->{output} =~ /^json(:([a-zA-Z]\w*)(:(.+))?)?$/) {
454 0         0 $self->debug("_output calling _output_json");
455 0   0     0 $output = $self->_output_json($row, $2 // "json");
456 0   0     0 $file = $4 // "/dev/stdout";
457              
458             # handle sql output, call with table name arg, refer to sub _output_sql
459             } elsif ($self->{output} =~ /^sql(:("([^"]+)"|(\w+))(:(.+))?)?$/) {
460 0         0 $self->debug("_output calling _output_sql");
461 0   0     0 $output = $self->_output_sql($row, $3 // $4 // "table");
      0        
462 0   0     0 $file = $6 // "/dev/stdout";
463              
464             # handle csv output, refer to sub _output_tsv
465             } elsif ($self->{output} =~ /^tsv(:(.+))?$/) {
466 0         0 $self->debug("_output calling _output_tsv");
467 0         0 $output = $self->_output_tsv($row);
468 0   0     0 $file = $2 // "/dev/stdout";
469              
470             # error on invalid output option
471             } else {
472 1         10 $self->fatal("invalid output option $self->{output}");
473             }
474              
475             # finished handling non-test output
476             }
477              
478             # open output filehandle, honor object append option
479             # open output file for first heading row call so we know we can open it
480             # so we don't continue running script when report file won't work
481 4 50 33     12 if ($file and not $self->{_output_fh}) {
482 0         0 my $mode = ">";
483 0 0       0 $mode = ">>" if $self->{append};
484 0         0 $self->debug("_output opening ${mode}$file");
485 0 0       0 open($self->{_output_fh}, $mode, $file)
486             or $self->fatal("unable to open ${mode}$file, $!");
487             }
488              
489             # output row
490             # note that for heading row the input row value is undefined
491             # normal rows are always output, heading row output only if append not set
492 4 50       7 if ($output) {
493 0 0 0     0 if ($row or not $self->{append}) {
494 0         0 syswrite $self->{_output_fh}, "$output\n";
495             }
496             }
497              
498             # finished _output method
499 4         10 $self->debug("_output finished");
500 4         8 return;
501             }
502              
503              
504              
505             sub _output_csv {
506              
507             # $output = $self->_output_csv($row)
508             # purpose: return output row data in csv format, or heading row
509             # \%row: row data, undef for heading row which returns heading row
510             # $output: single line of row output, or heading row if input row was undef
511              
512             =head2 output csv
513              
514             csv
515             csv:$file
516              
517             The csv output option can be used to output a csv file, /dev/stdout by default,
518             where all values are enclosed in double quotes and separated by commas.
519              
520             All csv outputs are doule quoted. Any double quote character in the outut data
521             will be escaped with an extra double quote character
522              
523             All end of line carraige return and linefeed characters in the output data
524             are replaced with spaces in the csv output. Multiline csv output data is not
525             supported.
526              
527             The output csv file will be created with a heading row when the new method is
528             called unless the append option was set when the new method was called.
529              
530             Refer to the OUTPUT OPTIONS section of this module for more info.
531              
532             =cut
533              
534             # read input object and row data hash reference
535 0   0 0     my $self = shift // die "missing self arg";
536 0           my $row = shift;
537 0           $self->debug("_output_csv starting");
538              
539             # init csv row output sting, will be heading row if input row is undef
540 0           my $output = undef;
541              
542             # declare sub to quote and escape csv value
543             # eol chars removed so concurrent batch outputs lines don't intermix
544             # double quotes are escaped with an extra double quote
545             # value is prefixed and suffixed with double quotes
546             sub _output_csv_escaped {
547 0   0 0     my $value = shift // "";
548 0           $value =~ s/(\r|\n)/ /g;
549 0           $value =~ s/"/""/g;
550 0           $value = '"'.$value.'"';
551 0           return $value;
552             }
553              
554             # determine if headings row is needed
555             # headings are needed if current script is not a batch script
556             # headings are needed for parent process of batch executions
557             # headings are not needed if the append option is set for table
558 0           my $headings_needed = 0;
559 0 0 0       if (not $INC{"Mnet/Batch.pm"} or not $MNet::Batch::fork_called) {
560 0 0         if (not $self->{append}) {
561 0 0         $headings_needed = 1 if not defined $row;
562             }
563             }
564              
565             # output heading row, if needed
566 0 0         if ($headings_needed) {
567 0           $self->debug("_output_csv generating heading row");
568 0           my @headings = ();
569 0           foreach my $column (@{$self->{_column_order}}) {
  0            
570 0           push @headings, _output_csv_escaped($column);
571             }
572 0           $output = join(",", @headings);
573             }
574              
575             # output data row, if defined
576 0 0         if (defined $row) {
577 0           my @data = ();
578 0           foreach my $column (@{$self->{_column_order}}) {
  0            
579 0           my $column_data = $row->{$column};
580 0 0         $column_data = ${$row->{$column}} if ref $row->{$column};
  0            
581 0           push @data, _output_csv_escaped($column_data);
582             }
583 0           $output = join(",", @data);
584             }
585              
586             # finished _output_csv method, return output line
587 0           $self->debug("_output_csv finished");
588 0           return $output;
589             }
590              
591              
592              
593             sub _output_dump {
594              
595             # $output = $self->_output_dump($row, $var)
596             # purpose: return output row data in perl Data::Dumper format
597             # \%row: row data, undef for heading row which returns undef (no heading row)
598             # $var: var name parsed from object output option used in Data::Dumper output
599             # $output: single line of row output, or undef if input row was undef
600              
601             =head2 output dump
602              
603             dump
604             dump $var
605             dump:$var:$file
606              
607             The dump output option writes one row per line in L format
608             prefixed by the specified var name, defaulting to 'dump' and /dev/stdout.
609              
610             This dump output can be read back into a perl script as follows:
611              
612             use Data::Dumper;
613             while () {
614             my ($line, $var) = ($_, undef);
615             my $table = $1 if $line =~ s/^\$(\S+)/\$var/ or die;
616             eval "$line";
617             print Dumper($var);
618             }
619              
620             Refer to the OUTPUT OPTIONS section of this module for more info.
621              
622             =cut
623              
624             # read input object and row data hash reference
625 0   0 0     my $self = shift // die "missing self arg";
626 0   0       my $row = shift // return;
627 0   0       my $var = shift // die "missing var arg";
628 0           $self->debug("_output_dump starting");
629              
630             # dereference error columns
631 0           foreach my $column (keys %$row) {
632 0 0         $row->{$column} = ${$row->{$column}} if ref $row->{$column};
  0            
633             }
634              
635             # create output row string, singl line dump
636 0           my $output = "\$$var = ".Mnet::Dump::line($row).";";
637              
638             # finished _output_dump method, return output line
639 0           $self->debug("_output_dump finished");
640 0           return $output;
641             }
642              
643              
644              
645             sub _output_json {
646              
647             # $output = $self->_output_json($row, $var)
648             # purpose: return output row data in json format
649             # \%row: row data, undef for heading row which returns undef (no heading row)
650             # $var: var name parsed from object output option used in json output
651             # $output: single line of row output, or undef if input row was undef
652              
653             =head2 output json
654              
655             json
656             json:$var
657             json:$var:$file
658              
659             The json output option writes one row per line in json format prefixed by the
660             specified var name, defaulting to 'json' and /dev/stdout. This requires that
661             the L module is available.
662              
663             The output json looks something like the example below:
664              
665             var = {"device":"test","error":null};
666              
667             This json output can be read back into a perl script as follows:
668              
669             use JSON;
670             use Data::Dumper;
671             while () {
672             my ($line, $var) = ($_, undef);
673             my $table = $1 if $line =~ s/^(\S+) = // or die;
674             $var = decode_json($line);
675             print Dumper($var);
676             }
677              
678             Refer to the OUTPUT OPTIONS section of this module for more info.
679              
680             =cut
681              
682             # read input object and row data hash reference
683 0   0 0     my $self = shift // die "missing self arg";
684 0   0       my $row = shift // return;
685 0   0       my $var = shift // die "missing var arg";
686 0           $self->debug("_output_json starting");
687              
688             # abort with an error if JSON module is not available
689             croak("Mnet::Report::Table json requires perl JSON module is installed")
690 0 0 0       if not $INC{'JSON.pm'} and not eval("require JSON; 1");
691              
692             # dereference error columns
693 0           foreach my $column (keys %$row) {
694 0 0         $row->{$column} = ${$row->{$column}} if ref $row->{$column};
  0            
695             }
696              
697             # create output data row
698             # json is sorted so that test output doesn't vary
699             # this will be undefined if called from new method
700 0           my $output = "$var = ".JSON->new->canonical->encode($row).";";
701              
702             # finished _output_json method, return output line
703 0           $self->debug("_output_json finished");
704 0           return $output;
705             }
706              
707              
708              
709             sub _output_log {
710              
711             # $self->_output_log
712             # purpose: output report row as info log entries
713              
714             # read input object and row data hash reference
715 0   0 0     my $self = shift // die "missing self arg";
716 0           my $row = shift;
717 0           $self->debug("_output_log starting");
718              
719             # dereference error columns
720 0           foreach my $column (keys %$row) {
721 0 0         $row->{$column} = ${$row->{$column}} if ref $row->{$column};
  0            
722             }
723              
724             # determine width of widest column, for formatting
725 0           my $width = 0;
726 0           foreach my $column (@{$self->{_column_order}}) {
  0            
727 0 0         $width = length($column) if length($column) > $width;
728             }
729              
730             # output data row to Mnet::Log
731             # row will be undefined if called from new method
732 0 0         if (defined $row) {
733 0           my $prefix = "row";
734 0           $self->info("$prefix {");
735 0           foreach my $column (@{$self->{_column_order}}) {
  0            
736 0           my $value = Mnet::Dump::line($row->{$column});
737 0           $self->info(sprintf("$prefix %-${width}s => $value", $column));
738             }
739 0           $self->info("$prefix }");
740             }
741              
742             # finished _output_log method
743 0           $self->debug("_output_log finished");
744 0           return;
745             }
746              
747              
748              
749             sub _output_sql {
750              
751             # $output = $self->_output_sql($row, $var)
752             # purpose: return output row data in sql format, as an insert statement
753             # \%row: row data, undef for heading row which returns undef (no heading row)
754             # $table: table name parsed from object output option used in sql output
755             # $output: single line of row output, or undef if input row was undef
756              
757             =head2 output sql
758              
759             sql
760             sql:$table
761             sql:"$table"
762             sql:$table:$file
763             sql:"$table":$file
764              
765             The sql output option writes one row per line as sql insert statements using
766             the specified table name, double-quoting non-word table names, defaulting to
767             "table" and /dev/stdout, in the following format:
768              
769             INSERT INTO (, ...) VALUES (, ...);
770              
771             Table and column names are double quoted, and values are single quoted. Single
772             quotes in values are escaped with an extra single quote character, LF and CR
773             characters are escaped as '+CHAR(10)+' and '+CHAR(13)+' respectively.
774              
775             Refer to the OUTPUT OPTIONS section of this module for more info.
776              
777             =cut
778              
779             # read input object and row data hash reference
780 0   0 0     my $self = shift // die "missing self arg";
781 0   0       my $row = shift // return;
782 0   0       my $table = shift // die "missing table arg";
783 0           $self->debug("_output_sql starting");
784              
785             # init sql row output sting, will be heading row if input row is undef
786 0           my $output = undef;
787              
788             # dereference error columns
789 0           foreach my $column (keys %$row) {
790 0 0         $row->{$column} = ${$row->{$column}} if ref $row->{$column};
  0            
791             }
792              
793             # output data row
794             # this will be undefined if called from new method
795             # double quote column names to handle unusual column names
796             # escape multiline outputs which concurrent batch procs can clobber
797 0 0         if (defined $row) {
798 0           my @sql_columns = ();
799 0           my @sql_values = ();
800 0           foreach my $column (@{$self->{_column_order}}) {
  0            
801 0           push @sql_columns, '"' . $column . '"';
802 0   0       my $value = $row->{$column} // "";
803 0           $value =~ s/'/''/g;
804 0           $value =~ s/\r/'+CHAR(10)+'/g;
805 0           $value =~ s/\n/'+CHAR(13)+'/g;
806 0           push @sql_values, "'" . $value . "'";
807             }
808 0           $output = "INSERT INTO \"$table\" ";
809 0           $output .= "(" . join(",", @sql_columns) . ") ";
810 0           $output .= "VALUES (" . join(",", @sql_values) . ");";
811             }
812              
813             # finished _output_sql method, return output line
814 0           $self->debug("_output_sql finished");
815 0           return $output;
816             }
817              
818              
819              
820             sub _output_test {
821              
822             # $self->_output_test(\%row)
823             # purpose: output test row data to stdout in Data::Dumper for when --test set
824             # \%row: row data, or undef for init call from new method w/Mnet::Batch loaded
825              
826             # read input object and row data hash reference
827 0   0 0     my $self = shift // die "missing self arg";
828 0           my $row = shift;
829 0           $self->debug("_output_test starting");
830              
831             # dereference error columns
832 0           foreach my $column (keys %$row) {
833 0 0         $row->{$column} = ${$row->{$column}} if ref $row->{$column};
  0            
834             }
835              
836             # determine width of widest column, for formatting
837 0           my $width = 0;
838 0           foreach my $column (@{$self->{_column_order}}) {
  0            
839 0 0         $width = length($column) if length($column) > $width;
840             }
841              
842             # output data row to Mnet::Log
843             # row will be undefined if called from new method
844 0 0 0       if (defined $row and $INC{"Mnet/Log.pm"}) {
    0          
845 0           $self->debug("_output_test calling _output_log");
846 0           $self->_output_log($row);
847              
848             # otherwise output data row to standard output
849             # row will be undefined if called from new method
850             } elsif (defined $row) {
851 0           syswrite STDOUT, "\nMnet::Report::Table row = {\n";
852 0           foreach my $column (@{$self->{_column_order}}) {
  0            
853 0           my $value = Mnet::Dump::line($row->{$column});
854 0           syswrite STDOUT, sprintf(" %-${width}s => $value\n", $column);
855             }
856 0           syswrite STDOUT, "}\n";
857             }
858              
859             # finished _output_test method
860 0           $self->debug("_output_test finished");
861 0           return;
862             }
863              
864              
865              
866             sub _output_tsv {
867              
868             # $output = $self->_output_tsv($row)
869             # purpose: return output row data in tsv format, or heading row
870             # \%row: row data, undef for heading row which returns heading row
871             # $output: single line of row output, or heading row if input row was undef
872              
873             =head2 output tsv
874              
875             tsv
876             tsv:$file
877              
878             The tsv output option can be used to output a tsv file, /dev/stdout by default,
879             where all values are separated by tab characters.
880              
881             All end of line carraige return, linefeeds, and tab characters in the output
882             data are replaced with spaces in the tsv output. Multiline tsv output data is
883             not supported.
884              
885             The output tsv file will be created with a heading row when the new method is
886             called unless the append option was set when the new method was called.
887              
888             Refer to the OUTPUT OPTIONS section of this module for more info.
889              
890             =cut
891              
892             # read input object and row data hash reference
893 0   0 0     my $self = shift // die "missing self arg";
894 0           my $row = shift;
895 0           $self->debug("_output_tsv starting");
896              
897             # init tsv row output sting, will be heading row if input row is undef
898 0           my $output = undef;
899              
900             # declare sub to quote and escape tsv value
901             # eol chars removed so concurrent batch outputs lines don't intermix
902             # tab chars removed to avoid conflicting with tsv column separator
903             sub _output_tsv_escaped {
904 0   0 0     my $value = shift // "";
905 0           $value =~ s/(\r|\n|\t)/ /g;
906 0           return $value;
907             }
908              
909             # determine if headings row is needed
910             # headings are needed if current script is not a batch script
911             # headings are needed for parent process of batch executions
912             # headings are not needed if the append option is set for table
913 0           my $headings_needed = 0;
914 0 0 0       if (not $INC{"Mnet/Batch.pm"} or not $MNet::Batch::fork_called) {
915 0 0         if (not $self->{append}) {
916 0 0         $headings_needed = 1 if not defined $row;
917             }
918             }
919              
920             # output heading row, if needed
921 0 0         if ($headings_needed) {
922 0           $self->debug("_output_tsv generating heading row");
923 0           my @headings = ();
924 0           foreach my $column (@{$self->{_column_order}}) {
  0            
925 0           push @headings, _output_tsv_escaped($column);
926             }
927 0           $output = join("\t", @headings);
928             }
929              
930             # output data row, if defined
931 0 0         if (defined $row) {
932 0           my @data = ();
933 0           foreach my $column (@{$self->{_column_order}}) {
  0            
934 0           my $column_data = $row->{$column};
935 0 0         $column_data = ${$row->{$column}} if ref $row->{$column};
  0            
936 0           push @data, _output_tsv_escaped($column_data);
937             }
938 0           $output = join("\t", @data);
939             }
940              
941             # finished _output_tsv method, return output line
942 0           $self->debug("_output_tsv finished");
943 0           return $output;
944             }
945              
946              
947              
948             # ensure that row data and error for all report objects has been output
949             # update global error var if Mnet::Log is loaded, ref used for error columns
950             # output rows for report objects that stored rows for end (nodefer not set)
951             # output row_on_error if there were unreported errors or nodefer was set
952             sub END {
953 1 50   1   1058 $Mnet::Report::Table::error = Mnet::Log::error() if $INC{'Mnet/Log.pm'};
954 1         2 foreach my $self (@{$Mnet::Report::Table::selves}) {
  1         3  
955 11         14 $self->_output($_) foreach @{$self->{_output_rows}};
  11         19  
956 11 0 33     19 if ($self->{_row_on_error} and $Mnet::Report::Table::error) {
957 0 0 0     0 if (not $self->{_row_on_error} or $self->{nodefer}) {
958 0         0 $self->_output($self->{_row_on_error});
959             }
960             }
961             }
962             }
963              
964              
965              
966             =head1 TESTING
967              
968             Mnet::Report::Table supports the L module test, record, and replay
969             functionality, tracking report data so it can be included in test results.
970              
971             =head1 SEE ALSO
972              
973             L
974              
975             L
976              
977             L
978              
979             L
980              
981             L
982              
983             L
984              
985             =cut
986              
987             # normal package return
988             1;
989