File Coverage

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