File Coverage

lib/Log/Shiras/Report/CSVFile.pm
Criterion Covered Total %
statement 188 191 98.4
branch 46 60 76.6
condition 5 6 83.3
subroutine 29 29 100.0
pod 1 3 33.3
total 269 289 93.0


line stmt bran cond sub pod time code
1             package Log::Shiras::Report::CSVFile;
2             our $AUTHORITY = 'cpan:JANDREW';
3 1     1   636 use version; our $VERSION = version->declare("v0.46.0");
  1         2  
  1         8  
4 1     1   74 use strict;
  1         1  
  1         19  
5 1     1   2 use warnings;
  1         2  
  1         24  
6 1     1   21 use 5.010;
  1         3  
7 1     1   5 use utf8;
  1         1  
  1         6  
8 1     1   20 use Moose;
  1         1  
  1         5  
9 1     1   4192 use namespace::autoclean;
  1         1  
  1         10  
10 1     1   59 use MooseX::StrictConstructor;
  1         1  
  1         7  
11 1     1   1882 use MooseX::HasDefaults::RO;
  1         2  
  1         6  
12             #~ use lib '../../../';
13             #~ use Log::Shiras::Unhide qw( :InternalReporTCSV );
14             ###InternalReporTCSV warn "You uncovered internal logging statements for Log::Shiras::Report::CSVFile-$VERSION" if !$ENV{hide_warn};
15 1     1   3895 use Text::CSV_XS 1.25;
  1         7901  
  1         47  
16 1     1   6 use File::Copy qw( copy );
  1         2  
  1         42  
17 1     1   5 use File::Temp;
  1         1  
  1         56  
18             #~ $File::Temp::DEBUG = 1;
19 1     1   4 use Carp qw( confess cluck );
  1         2  
  1         35  
20 1     1   4 use Fcntl qw( :flock LOCK_EX LOCK_UN SEEK_END);#
  1         1  
  1         141  
21 1         11 use MooseX::Types::Moose qw(
22             FileHandle ArrayRef HashRef Str Bool
23 1     1   4 );
  1         2  
24 1     1   3635 use lib '../../../../lib';
  1         1  
  1         8  
25             ###InternalReporTCSV use Log::Shiras::Switchboard;
26             ###InternalReporTCSV my $switchboard = Log::Shiras::Switchboard->instance;
27 1     1   124 use Log::Shiras::Types qw( HeaderArray HeaderString CSVFile IOFileType );
  1         1  
  1         6  
28              
29             #########1 Public Attributes 3#########4#########5#########6#########7#########8#########9
30              
31             has file =>(
32             isa => CSVFile,
33             writer => 'set_file_name',
34             reader => 'get_file_name',
35             clearer => '_clear_file',
36             predicate => '_has_file',
37             required => 1,
38             coerce => 1,
39             );
40            
41             has headers =>(
42             isa => HeaderArray,
43             traits =>['Array'],
44             writer => 'set_headers',
45             reader => 'get_headers',
46             predicate => 'has_headers',
47             clearer => '_clear_headers',
48             handles =>{
49             number_of_headers => 'count',
50             },
51             coerce => 1,
52             );
53            
54             has reconcile_headers =>(
55             isa => Bool,
56             writer => 'set_reconcile_headers',
57             reader => 'should_reconcile_headers',
58             default => 1,
59             );
60              
61             has test_first_row =>(
62             isa => Bool,
63             writer => '_test_first_row',
64             reader => 'should_test_first_row',
65             default => 1,
66             );
67              
68             #########1 Public Methods 3#########4#########5#########6#########7#########8#########9
69              
70             sub add_line{
71              
72 7     7 1 962 my ( $self, $input_ref ) = @_;
73             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 2,
74             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::add_line',
75             ###InternalReporTCSV message =>[ 'Adding a line to the csv file -' . $self->get_file_name . '- :', $input_ref ], } );
76 7         6 my $message_ref;
77 7         5 my( $first_ref, @other_args ) = @{$input_ref->{message}};
  7         13  
78 7 50       25 if( !$first_ref ){
    100          
    50          
79             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 1,
80             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::add_line::_find_the_actual_message',
81             ###InternalReporTCSV message =>[ 'No data in the first position - adding an empty row' ], } );
82 0         0 $message_ref = $self->_build_message_from_arrayref( [] );
83             }elsif( @other_args ){
84             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 1,
85             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::add_line::_find_the_actual_message',
86             ###InternalReporTCSV message =>[ 'Multiple values passed - treating the inputs like a list' ], } );
87 3         12 $message_ref = $self->_build_message_from_arrayref( [ $first_ref, @other_args ] );
88             }elsif( is_HashRef( $first_ref ) ){
89             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 1,
90             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::add_line::_find_the_actual_message',
91             ###InternalReporTCSV message =>[ 'Using the ref as it stands:', $first_ref ], } );
92 4         505 $message_ref = $self->_build_message_from_hashref( $first_ref );
93             }else{
94             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 3,
95             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::add_line::_find_the_actual_message',
96             ###InternalReporTCSV message =>[ 'Treating the input as a one element string' ], } );
97 0         0 $message_ref = $self->_build_message_from_arrayref( [ $first_ref ] );
98             }
99             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 3,
100             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::add_line',
101             ###InternalReporTCSV message =>[ "committing the message:", $message_ref ], } );
102 7         154 $self->_send_array_ref( $self->_get_file_handle, $message_ref );
103            
104 7         303 return 1;
105             }
106              
107             #########1 Private Attributes 3#########4#########5#########6#########7#########8#########9
108              
109             has _file_handle =>(
110             isa => IOFileType,
111             writer => '_set_file_handle',
112             reader => '_get_file_handle',
113             clearer => '_clear_file_handle',
114             predicate => '_has_file_handle',
115             init_arg => undef,
116             );
117              
118             has _file_headers =>(
119             isa => HeaderArray,
120             traits =>['Array'],
121             writer => '_set_file_headers',
122             reader => '_get_file_headers',
123             clearer => '_clear_file_headers',
124             predicate => '_has_file_headers',
125             handles =>{
126             _file_header_count => 'count',
127             },
128             init_arg => undef,
129             );
130              
131             has _expected_header_lookup =>(
132             isa => HashRef,
133             traits =>['Hash'],
134             writer => '_set_header_lookup',
135             reader => '_get_header_lookup',
136             clearer => '_clear_header_lookup',
137             predicate => '_has_header_lookup',
138             handles =>{
139             _get_header_position => 'get',
140             _has_header_named => 'exists',
141             },
142             init_arg => undef,
143             );
144              
145             has _csv_parser =>(
146             isa => 'Text::CSV_XS',
147             writer => '_set_csv_parser',
148             clearer => '_clear_csv_parser',
149             init_arg => undef,
150             handles =>{
151             _set_parsing_header => 'header',
152             _send_array_ref => 'say',
153             _send_hash_ref => 'print_hr',
154             _read_next_line => 'getline',
155             _separator_char => 'sep_char',
156             },
157             );
158              
159             #########1 Private Methods 3#########4#########5#########6#########7#########8#########9
160              
161             sub BUILD{
162 5     5 0 221 my( $self, ) = @_;
163             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 2,
164             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::BUILD',
165             ###InternalReporTCSV message =>[ "Organizing the new file instance"], } );
166            
167             # Open and collect the header if available
168 5         107 $self->_open_file( $self->get_file_name );
169             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 1,
170             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::BUILD',
171             ###InternalReporTCSV message =>[ "Open file complete"], } );
172            
173             # Check requested headers against an empty file
174 5 100       113 if( $self->has_headers ){
175 2         40 my $header_ref = $self->get_headers;
176 2         12 $self->_set_expected_header_lookup( $header_ref );
177 2 100 66     48 if( $self->should_reconcile_headers and !$self->_has_file_headers ){
178             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 1,
179             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::BUILD',
180             ###InternalReporTCSV message =>[ "Ensuring the requested headers are in the file:", $header_ref ], } );
181 1         4 $self->_add_headers_to_file( $header_ref );
182             }
183             }
184             #~ confess "Died here";
185 5         476 return 1;
186             }
187              
188             after 'set_file_name' => sub{ my( $self, $file ) = @_; $self->_open_file( $file ) };
189              
190             sub _open_file{
191              
192 11     11   13 my ( $self, $file ) = @_;
193             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 2,
194             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::_open_file',
195             ###InternalReporTCSV message =>[ "Arrived at _open_file for:", $file ], } );
196 11         254 $self->_clear_file_handle;
197 11         284 $self->_clear_file_headers;
198 11         235 $self->_clear_csv_parser;
199            
200             # Build the csv parser
201 11         78 $self->_set_csv_parser( Text::CSV_XS->new({ binary => 1, eol => $\, auto_diag => 1 }) );#
202            
203             # Open the file handle and collect the header if available
204 1 50   1   6 open( my $fh, "+<:encoding(UTF-8)", $file ) or confess "Can't open $file: $!";
  1         1  
  1         5  
  11         289  
205 11         8994 binmode( $fh );
206 11         38 flock( $fh, LOCK_EX );
207 11         306 $self->_set_file_handle( $fh );
208             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 1,
209             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::_open_file',
210             ###InternalReporTCSV message =>[ 'Read file handle built: ' . -s $fh ], } );
211            
212             # Collect the header if available
213 11 100       255 if( -s $self->_get_file_handle ){
214             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 1,
215             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::_open_file',
216             ###InternalReporTCSV message =>[ "The file appears to have pre-existing content (headers)" ], } );
217 7         7 my $header_ref;
218 7         30 @$header_ref = $self->_set_parsing_header( $fh );
219             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 1,
220             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::_open_file',
221             ###InternalReporTCSV message =>[ "File headers are: " . join( '~|~', @$header_ref ) ], } );
222 7         2087 $self->_set_file_headers( $header_ref );
223             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 1,
224             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::_open_file',
225             ###InternalReporTCSV message =>[ "File headers set" ], } );
226             }else{
227             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 1,
228             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::_open_file',
229             ###InternalReporTCSV message =>[ "The file is zero size" ], } );
230             }
231            
232             # Get to the end for add_line (in case you weren't there before)
233 11 50       232 seek( $self->_get_file_handle, 0, SEEK_END) or confess "Can't seek (end) on $file: $!";
234            
235 11         19 return 1;
236             }
237              
238             around '_set_file_headers' => sub{
239             my( $_set_file_headers, $self, $header_ref ) = @_;
240             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 1,
241             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::_set_file_headers',
242             ###InternalReporTCSV message =>[ 'Attempting to set the file headers to:', $header_ref ], } );
243             if( $self->should_reconcile_headers ){
244             my( $one_extra, $two_extra ) = $self->_test_headers( $header_ref, $self->get_headers );
245             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 0,
246             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::_set_file_headers',
247             ###InternalReporTCSV message =>[ 'Returned from the header test:', $one_extra, $two_extra ], } );
248             $self->set_reconcile_headers( 0 );
249             if( $two_extra ){
250             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 3,
251             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::_set_file_headers',
252             ###InternalReporTCSV message =>[ 'There are more expected headers than were found in the file:', $two_extra ], } );
253             push @$header_ref, @$two_extra;
254             $self->_add_headers_to_file( $header_ref );
255             }
256             if( $one_extra ){
257             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 3,
258             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::_set_file_headers',
259             ###InternalReporTCSV message =>[ 'There are more file headers than expected headers:', $one_extra ], } );
260             $self->set_headers( $header_ref );
261             }
262             $self->set_reconcile_headers( 1 );
263             }
264             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 3,
265             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::_set_file_headers',
266             ###InternalReporTCSV message =>[ "Setting file headers to: ", $header_ref ], } );
267             $self->$_set_file_headers( $header_ref );
268             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 2,
269             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::_set_file_headers',
270             ###InternalReporTCSV message =>[ 'Final file headers:', $self->_get_file_headers ], } );
271             };
272              
273             around 'set_headers' => sub{
274             my( $set_headers_method, $self, $header_ref ) = @_;
275             $self->_clear_header_lookup;
276             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 1,
277             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::set_headers',
278             ###InternalReporTCSV message =>[ 'Received a request to set headers to:', $header_ref ], } );
279             $header_ref = $self->_scrub_header_array( $header_ref );
280             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 1,
281             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::set_headers',
282             ###InternalReporTCSV message =>[ 'Attempting to set the requested headers with:', $header_ref ], } );
283             $self->_set_expected_header_lookup( $header_ref );
284             my( $one_extra, $two_extra, $translation );
285             if( $self->should_reconcile_headers ){
286             my $file_headers = $self->_get_file_headers;
287             ( $one_extra, $two_extra, $translation ) = $self->_test_headers( $file_headers, $header_ref, );
288             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 0,
289             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::_set_file_headers',
290             ###InternalReporTCSV message =>[ 'Returned from the header test:', $one_extra, $two_extra, $translation ], } );
291             $self->set_reconcile_headers( 0 );
292             if( $two_extra ){
293             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 3,
294             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::_set_file_headers',
295             ###InternalReporTCSV message =>[ 'There are more expected headers than were found in the file:', $two_extra ], } );
296             my $new_ref;
297             push @$new_ref, @$file_headers if $file_headers;
298             push @$new_ref, @$two_extra;
299             $self->_add_headers_to_file( $new_ref );
300             $header_ref = $new_ref;
301             }
302             $self->set_reconcile_headers( 1 );
303             }
304             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 3,
305             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::_set_file_headers',
306             ###InternalReporTCSV message =>[ "Setting requested headers to: ", $header_ref ], } );
307             $self->$set_headers_method( $header_ref );
308             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 2,
309             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::set_headers',
310             ###InternalReporTCSV message =>[ 'Final requested headers resolved to:', $header_ref,
311             ###InternalReporTCSV '...with passing-to translation resolved as:', $translation ], } );
312             return $translation;
313             };
314              
315             sub _add_headers_to_file{
316              
317 6     6   8 my ( $self, $new_ref ) = @_;
318             #~ my $new_line = join( $self->_separator_char, @$new_ref ) . "\n";
319             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 2,
320             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::_add_headers_to_file',
321             ###InternalReporTCSV message =>[ "Arrived at _add_headers_to_file for:", $new_ref, ], } );
322            
323             # Make a temp file to create new data
324 6         33 my $temp_dir = File::Temp->newdir( CLEANUP => 1 );
325 6         1649 my $fh = File::Temp->new( UNLINK => 0, DIR => $temp_dir );
326 6         1470 my $temp_parser = Text::CSV_XS->new({ binary => 1, sep_char => $self->_separator_char, eol => $\, auto_diag => 1 });#
327             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 0,
328             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::_add_headers_to_file',
329             ###InternalReporTCSV message =>[ "Tempfile open: " . $fh->filename, ], } );
330            
331             # Add the new header
332 6         629 $temp_parser->say( $fh, $new_ref );
333             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 0,
334             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::_add_headers_to_file',
335             ###InternalReporTCSV message =>[ "Added headers to the tempfile: ", $new_ref, ], } );
336            
337             # Write the rest of the lines (except the old header)
338 6         395 my $original_fh = $self->_get_file_handle;
339 6         129 $self->_clear_file_handle;
340 6         5 my $first_line = 1;
341 6         19 seek( $original_fh, 0, 0 );
342 6         21 while (my $row = $self->_read_next_line($original_fh)) {
343 5 100       221 if( $first_line ){
344 3         4 $first_line = 0;
345 3         11 next;
346             }
347             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 0,
348             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::_add_headers_to_file',
349             ###InternalReporTCSV message =>[ "Printing line to tempfile:", $row], } );
350 2         6 $temp_parser->say( $fh, $row );
351             }
352            
353             # Close the original file
354 6         416 flock( $original_fh, LOCK_UN );
355 6 50       42 close( $original_fh ) or confess "Couldn't close file: $!";
356             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 0,
357             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::_add_headers_to_file',
358             ###InternalReporTCSV message =>[ "Closed the original file handle" ], } );
359            
360             # Close the new tempfile
361 6         121 flock( $fh, LOCK_UN );
362 6         24 close( $fh );
363             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 0,
364             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::_add_headers_to_file',
365             ###InternalReporTCSV message =>[ "Closed the new temp file" ], } );
366            
367             # Replace the original file with the tempfile
368 6 50       23 copy( $fh->filename, $self->get_file_name ) or confess "Couldn't copy file: $!";
369             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 0,
370             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::_add_headers_to_file',
371             ###InternalReporTCSV message =>[ "Original file replaced: " . $self->get_file_name,
372             ###InternalReporTCSV '..with file: ' . $fh->filename ], } );
373 6         1129 $fh = undef;
374            
375             # Re-run the file to get the headers registered with Text::CSV_XS;
376 6         18 $self->_open_file( $self->get_file_name );
377             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 0,
378             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::_add_headers_to_file',
379             ###InternalReporTCSV message =>[ "Updated file re-test complete" ], } );
380            
381 6         40 return 1;
382             }
383              
384             sub _test_headers{
385              
386 6     6   9 my ( $self, $header_ref_1, $header_ref_2 ) = @_;
387             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 2,
388             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::_test_headers',
389             ###InternalReporTCSV message =>[ "Arrived at test headers with:", $header_ref_1, $header_ref_2 ], } );
390 6         6 my( $one_extra, $two_extra, $translation );
391 6 50       15 if( !$header_ref_2 ){
392             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 3,
393             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::_test_headers',
394             ###InternalReporTCSV message =>[ "No second header list passed for testing" ], } );
395 0         0 $one_extra = $header_ref_1;
396             }else{
397 6         6 my $x = 0;
398 6         13 for my $second_header ( @$header_ref_2 ){
399             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 0,
400             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::_test_headers',
401             ###InternalReporTCSV message =>[ "Testing second header: $second_header" ], } );
402 25         12 my $y = 0;
403 25         20 my $found_match = 0;
404 25         19 NEWHEADERTEST: for my $first_header ( @$header_ref_1 ){
405             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 0,
406             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::_test_headers',
407             ###InternalReporTCSV message =>[ "Testing first header -$first_header- for a match" ], } );
408 43 100       48 if( $second_header eq $first_header ){
409             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 0,
410             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::_test_headers',
411             ###InternalReporTCSV message =>[ "Second header list -$second_header- at position: $x",
412             ###InternalReporTCSV "matches first header list header -$first_header- at position: $y" ], } );
413 12         18 $translation->{$x} = $y;
414 12         7 $found_match = 1;
415 12         12 last NEWHEADERTEST;
416             }
417 31         21 $y++;
418             }
419 25 100       38 push @$two_extra, $second_header if !$found_match;
420 25         26 $x++;
421             }
422 6         15 for my $pos ( 0 .. $#$header_ref_1 ){
423 15 100       26 if( !exists $translation->{$pos} ){
424 3         5 push @$one_extra, $header_ref_1->[$pos];
425             }
426             }
427 6         9 my $next_pos = $#$header_ref_1 + 1;
428 6         12 for my $pos ( 0 .. $#$header_ref_2 ){
429 25 100       37 if( !exists $translation->{$pos} ){
430 13         19 $translation->{$pos} = $next_pos++;
431             }
432             }
433             }
434             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 2,
435             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::_test_headers',
436             ###InternalReporTCSV message =>[ "Finished with header list 1 extra:", $one_extra,
437             ###InternalReporTCSV "...and header list 2 extra:", $two_extra,
438             ###InternalReporTCSV "...and translation ref:", $translation ], } );
439 6         13 return( $one_extra, $two_extra, $translation );
440             }
441              
442             sub _build_message_from_arrayref{
443 3     3   4 my( $self, $array_ref )= @_;
444             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 2,
445             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::add_line::_build_message_from_arrayref',
446             ###InternalReporTCSV message =>[ 'Testing the message from an array ref: ' . ($self->should_test_first_row//0), $array_ref ], } );
447 3 100       82 my @expected_headers = $self->has_headers ? @{$self->get_headers} : ();
  2         42  
448 3 100       69 if( $self->should_test_first_row ){
449             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 1,
450             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::add_line::_build_message_from_arrayref',
451             ###InternalReporTCSV message =>[ 'First row - testing if the list matches the header count' ], } );
452            
453 2 50       5 if( $#$array_ref != $#expected_headers ){
454 2 100       5 if( scalar( @expected_headers ) == 0 ){
455             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 3,
456             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::add_line::_build_message_from_arrayref',
457             ###InternalReporTCSV message =>[ 'Adding dummy file headers' ], } );
458 1         2 my $dummy_headers;
459 1         2 map{ $dummy_headers->[$_] = "header_" . $_ } ( 0 .. $#$array_ref );
  6         10  
460             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 1,
461             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::add_line::_build_message_from_arrayref',
462             ###InternalReporTCSV message =>[ 'New dummy headers:', $dummy_headers ], } );
463 1 50       107 cluck "Setting dummy headers ( " . join( ', ', @$dummy_headers ) . " )" if !$ENV{hide_warn};
464 1         26 $self->set_reconcile_headers( 1 );
465 1         4 $self->set_headers( $dummy_headers );
466             }else{
467             cluck "The first added row has -" . scalar( @$array_ref ) .
468             "- items - but the report expects -" .
469 1 50       129 scalar( @expected_headers ) . "- items" if !$ENV{hide_warn};
470             }
471             }
472 2         51 $self->_test_first_row ( 0 );
473             }
474             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 2,
475             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::add_line::_build_message_from_arrayref',
476             ###InternalReporTCSV message =>[ 'Returning message ref:', $array_ref ], } );
477 3         7 return $array_ref;
478             }
479              
480             sub _build_message_from_hashref{
481 4     4   4 my( $self, $hash_ref )= @_;
482             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 2,
483             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::add_line::_build_message_from_hashref',
484             ###InternalReporTCSV message =>[ 'Building the array ref from the hash ref: ' . ($self->should_test_first_row//0), $hash_ref ], } );
485            
486             # Scrub the hash
487 4         4 my( $better_hash, @missing_list );
488 4         10 for my $key ( keys %$hash_ref ){
489 12         19 my $fixed_key = $self->_scrub_header_string( $key );
490             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 0,
491             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::add_line::_build_message_from_hashref',
492             ###InternalReporTCSV message =>[ "Managing key -$fixed_key- for key: $key" ], } );
493 12 100 100     284 push @missing_list, $fixed_key if $self->should_test_first_row and !$self->_has_header_named( $fixed_key );
494 12         25 $better_hash->{$fixed_key} = $hash_ref->{$key};
495             }
496 4         87 $self->_test_first_row( 0 );
497             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 0,
498             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::add_line::_build_message_from_hashref',
499             ###InternalReporTCSV message =>[ "Updated hash message:", $better_hash,
500             ###InternalReporTCSV "...with missing list:", @missing_list ], } );
501            
502             # Handle first row errors
503 4 100       8 if( @missing_list ){
504 2 100       41 my @expected_headers = $self->has_headers ? @{$self->get_headers} : ();
  1         21  
505 2         3 push @expected_headers, @missing_list;
506             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 3,
507             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::add_line::_build_message_from_hashref',
508             ###InternalReporTCSV message =>[ "Updating the expected headers with new data", [@expected_headers] ], } );
509 2 50       219 cluck "Adding headers from the first hashref ( " . join( ', ', @missing_list ) . " )" if !$ENV{hide_warn};
510 2         51 $self->set_reconcile_headers( 1 );
511 2         10 $self->set_headers( [@expected_headers] );
512             }
513            
514             # Build the array_ref
515 4         5 my $array_ref = [];
516             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 2,
517             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::add_line::_build_message_from_hashref',
518             ###InternalReporTCSV message =>[ 'Building an array ref with loookup:', $self->_get_header_lookup ], } );
519 4         9 for my $header ( keys %$better_hash ){
520 12 100       327 if( $self->_has_header_named( $header ) ){
521 11         282 $array_ref->[$self->_get_header_position( $header )] = $better_hash->{$header};
522             }else{
523 1 50       114 cluck "found a hash key in the message that doesn't match the expected header ( $header )" if !$ENV{hide_warn};
524             }
525             }
526            
527             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 2,
528             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::add_line::_build_message_from_hashref',
529             ###InternalReporTCSV message =>[ 'Returning message array ref:', $array_ref ], } );
530 4         11 return $array_ref;
531             }
532              
533             sub _set_expected_header_lookup{
534 6     6   7 my ( $self, $hash_ref ) = @_;
535             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 2,
536             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::_set_expected_header_lookup',
537             ###InternalReporTCSV message =>[ "Arrived at _set_expected_header_lookup with:", $hash_ref ], } );
538 6         8 my( $i, $positions, ) = ( 0, {} );
539 6         8 map{ $positions->{$_} = $i++ } @$hash_ref;
  25         34  
540             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 2,
541             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::_set_expected_header_lookup',
542             ###InternalReporTCSV message =>[ "Header lookup hash is:", $positions ], } );
543 6         161 $self->_set_header_lookup( $positions );
544             }
545              
546             sub _scrub_header_array{
547 4     4   6 my ( $self, @args ) = @_;
548             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 2,
549             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::_scrub_header_array',
550             ###InternalReporTCSV message =>[ "Arrived at _scrub_header_array:", @args ], } );
551 4         6 my $new_ref = [];
552 4         5 for my $header ( @{$args[0]} ){
  4         8  
553 17         67 push @$new_ref, $self->_scrub_header_string( $header );
554             }
555             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 2,
556             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::_scrub_header_array',
557             ###InternalReporTCSV message =>[ "Updated header is:", $new_ref ], } );
558 4         5 return $new_ref;
559             }
560              
561             sub _scrub_header_string{
562 29     29   28 my ( $self, $string ) = @_;
563             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 2,
564             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::_scrub_header_string',
565             ###InternalReporTCSV message =>[ "Arrived at _scrub_header_string with: $string" ], } );
566 29         33 $string = lc( $string );
567             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 0,
568             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::_scrub_header_string',
569             ###InternalReporTCSV message =>[ "The updated string is: $string" ], } );
570 29         25 $string =~ s/\n/ /gsxm;
571             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 0,
572             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::_scrub_header_string',
573             ###InternalReporTCSV message =>[ "The updated string is: $string" ], } );
574 29         21 $string =~ s/\r/ /gsxm;
575             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 0,
576             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::_scrub_header_string',
577             ###InternalReporTCSV message =>[ "The updated string is: $string" ], } );
578 29         34 $string =~ s/\s/_/gsxm;
579             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 0,
580             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::_scrub_header_string',
581             ###InternalReporTCSV message =>[ "The updated string is: $string" ], } );
582 29         22 chomp $string;
583             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 2,
584             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::_scrub_header_string',
585             ###InternalReporTCSV message =>[ "The final string is: $string" ], } );
586 29         37 return $string;
587             }
588              
589             sub DEMOLISH{
590 5     5 0 1505 my ( $self ) = @_;
591             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 2,
592             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::DEMOLISH',
593             ###InternalReporTCSV message =>[ "Arrived at DEMOLISH" ], } ) if $switchboard;
594 5 50       114 if( $self->_has_file_handle ){
595 5         124 flock( $self->_get_file_handle, LOCK_UN );
596 5 50       117 close( $self->_get_file_handle ) or confess "Couldn't close the file handle";
597 5         124 $self->_clear_file_handle;
598             ###InternalReporTCSV $switchboard->master_talk( { report => 'log_file', level => 1,
599             ###InternalReporTCSV name_space => 'Log::Shiras::Report::CSVFile::DEMOLISH',
600             ###InternalReporTCSV message =>[ "Arrived at DEMOLISH" ], } ) if $switchboard;
601             }
602             }
603              
604             #########1 Phinish 3#########4#########5#########6#########7#########8#########9
605              
606             __PACKAGE__->meta->make_immutable;
607              
608             1;
609             # The preceding line will help the module return a true value
610              
611             #########1 main pod docs 3#########4#########5#########6#########7#########8#########9
612              
613             __END__
614              
615             =head1 NAME
616              
617             Log::Shiras::Report::CSVFile - A report base for csv files
618              
619             =head1 SYNOPSIS
620              
621             use Modern::Perl;
622             #~ use Log::Shiras::Unhide qw( :InternalReporTCSV );
623             use Log::Shiras::Switchboard;
624             use Log::Shiras::Telephone;
625             use Log::Shiras::Report;
626             use Log::Shiras::Report::CSVFile;
627             use Log::Shiras::Report::Stdout;
628             $ENV{hide_warn} = 1;
629             $| = 1;
630             my $operator = Log::Shiras::Switchboard->get_operator(
631             name_space_bounds =>{
632             UNBLOCK =>{
633             to_file => 'info',# for info and more urgent messages
634             },
635             },
636             reports =>{
637             to_file =>[{
638             superclasses =>[ 'Log::Shiras::Report::CSVFile' ],
639             roles =>[ 'Log::Shiras::Report' ],# checks inputs and class requirements
640             file => 'test.csv',
641             }],
642             }
643             );
644             my $telephone = Log::Shiras::Telephone->new( report => 'to_file' );
645             $telephone->talk( level => 'info', message => 'A new line' );
646             $telephone->talk( level => 'trace', message => 'A second line' );
647             $telephone->talk( level => 'warn', message =>[ {
648             header_0 => 'A third line',
649             new_header => 'new header starts here' } ] );
650            
651             #######################################################################################
652             # Synopsis file (test.csv) output
653             # 01: header_0
654             # 02: "A new line"
655             # 03: "A third line"
656             #######################################################################################
657            
658             #######################################################################################
659             # Synopsis file (test.csv) output with line 24 commented out
660             # 01: header_0,new_header
661             # 02: "A third line","new header starts here"
662             #######################################################################################
663            
664             =head1 DESCRIPTION
665              
666             This is a report module that can act as a destination in the
667             L<Log::Shiras::Switchboard/reports> name-space. It is meant to be fairly flexible and
668             will have most of the needed elements in the class without added roles. An instance
669             of the class can be built either with ->new or using the implied
670             L<MooseX::ShortCut::BuildInstance> helpers. (See lines 18 - 20 in the example) When the
671             report is set up any call to that report namespace will then implement the L<add_line
672             |/add_line> method of this class.
673              
674             As implied in the Synopsis one of the features of this class is the fact that it will try to
675             reconcile the headers to inbound data and header requests. This class will attempt to
676             reconcile any deviation between the first passed row and the header. Subsequent added
677             rows using a passed array ref will add all values without warning whether the count matches
678             the header count or not. Subsequent added rows using a passed hashref will only used the
679             headers in the fixed L<header|/header> list but will warn for any passed headers not matching
680             the header list.
681              
682             This class will attempt to obtain an exclusive lock on the file. If the file is previously
683             locked it will wait. That will allow you to attach more than one report script to the same
684             file name and not overwrite lines. On the other hand this does have the potential to create
685             scripts that appear to be hung.
686              
687             =head2 Warning
688              
689             This class will always use the header list when adding new hash values. As a consequence
690             there can be no duplicates in the header list after it is coereced to this files requirements.
691             Since the class allows for mixed passing of array refs and hash refs it also has the
692             no duplicate header requirement with array ref handling too.
693              
694             =head2 Attributes
695              
696             Data passed to ->new when creating an instance. For modification of these attributes
697             after the instance is created see the attribute methods.
698              
699             =head3 file
700              
701             =over
702              
703             B<Definition:> This is the file name to be used by the .csv file. This should include the
704             full file path. If the file does not exist then the file will be created.
705              
706             B<Default:> None
707              
708             B<Required:> Yes
709              
710             B<Range:> it must have a .csv extention and can be opened
711              
712             B<attribute methods>
713              
714             =over
715              
716             B<set_file_name( $file_name )>
717              
718             =over
719              
720             B<Description> used to set the attribute
721              
722             =back
723              
724             B<get_file_name>
725              
726             =over
727              
728             B<Description> used to return the current attribute value
729              
730             =back
731              
732             =back
733              
734             =back
735              
736             =head3 headers
737              
738             =over
739              
740             B<Definition:> This an array ref of the requested headers in the file. Each of the headers
741             must match header string requirements. The header strings will be coerced as needed buy forcing
742             then lower case and removing any newlines.
743              
744             B<Default:> None
745              
746             B<Required:> No
747              
748             B<Range:> An array ref of strings starting with a lower case letter and containing letters,
749             underscores, and numbers
750              
751             B<attribute methods>
752              
753             =over
754              
755             B<set_headers( $array_ref )>
756              
757             =over
758              
759             B<Description> used to set all the attribute at once
760              
761             =back
762              
763             B<get_headers>
764              
765             =over
766              
767             B<Description> used to return all the attribute at once
768              
769             =back
770              
771             B<has_headers>
772              
773             =over
774              
775             B<Description> predicate for the whole attribute
776              
777             =back
778              
779             B<number_of_headers>
780              
781             =over
782              
783             B<Description> Returns the complete header count list
784              
785             =back
786              
787             =back
788              
789             =back
790              
791             =head3 reconcile_headers
792              
793             =over
794              
795             B<Definition:> It may be that when you open a file the file already has headers. This
796             attribute determines if the action or L<requested headers|/headers> are merged with the
797             file headers. In the merge the file headers are given order precedence so new requested
798             headers wind up at the end even when that means the requested headers are added out of
799             order to the original request!
800              
801             B<Default:> 1 = the headers will be reconciled
802              
803             B<Range:> Boolean
804              
805             B<attribute methods>
806              
807             =over
808              
809             B<set_reconcile_headers( $bool )>
810              
811             =over
812              
813             B<Description> used to set the attribute
814              
815             =back
816              
817             B<should_reconcile_headers>
818              
819             =over
820              
821             B<Description> used to return the current attribute value
822              
823             =back
824              
825             =back
826              
827             =back
828              
829             =head3 test_first_row
830              
831             =over
832              
833             B<Definition:> It may be that when you send the first row after instance instantiation
834             that the row and the headers don't agree. This will update the requested headers (
835             L<and maybe the file headers|/reconcile headers>) with any variation between the two.
836             In the case of a passed array ref no header change is implemented but a warning is
837             emitted when the passed list and the header list don't have the same count. For
838             passed hash refs new headers are added to the end of the requested headers. After
839             the first line no warning is emitted for passed array refs that don't match and
840             new hash keys (and their values) that don't match the header will just be left off
841             the report. New hash keys for the first row will be added in a random order.
842              
843             B<Default:> 1 = the first row will attempt reconciliation
844              
845             B<Range:> Boolean
846              
847             B<attribute methods>
848              
849             =over
850              
851             B<should_test_first_row>
852              
853             =over
854              
855             B<Description> used to return the current attribute value
856              
857             =back
858              
859             =back
860              
861             =back
862              
863             =head2 Methods
864              
865             =head3 new( %args )
866              
867             =over
868              
869             B<Definition:> This creates a new instance of the CSVFile L<report
870             |Log::Shiras::Switchboard/reports> class.
871              
872             B<Range:> It will accept any or none of the L<Attributes|/Attributes>
873              
874             B<Returns:> A report class to be stored in the switchboard.
875              
876             =back
877              
878             =head3 add_line( $message_ref )
879              
880             =over
881              
882             B<Definition:> This is the method called by the switchboard to add lines to the report. It will
883             expect a message compatible with L<Log::Shiras::Switchboard/master_talk( $args_ref )>. There is
884             some flexibility in the consumption of the value within the 'message' key. This package will
885             check if there is more than one item and handle it like an elements list. If there is only one
886             item and it is a hash ref it will attempt to consume the hashref as having keys matching the
887             columns. Other single elements will be consumed as sub-elements of an element list.
888              
889             B<Returns:> 1 (or dies)
890              
891             =back
892              
893             =head1 GLOBAL VARIABLES
894              
895             =over
896              
897             =item B<$ENV{hide_warn}>
898              
899             The module will warn when debug lines are 'Unhide'n. In the case where the you
900             don't want these notifications set this environmental variable to true.
901              
902             =back
903              
904             =head1 SUPPORT
905              
906             =over
907              
908             L<Log-Shiras/issues|https://github.com/jandrew/Log-Shiras/issues>
909              
910             =back
911              
912             =head1 TODO
913              
914             =over
915              
916             B<1.> Nothing L<currently|/SUPPORT>
917              
918             =back
919              
920             =head1 AUTHOR
921              
922             =over
923              
924             =item Jed Lund
925              
926             =item jandrew@cpan.org
927              
928             =back
929              
930             =head1 COPYRIGHT
931              
932             This program is free software; you can redistribute
933             it and/or modify it under the same terms as Perl itself.
934              
935             The full text of the license can be found in the
936             LICENSE file included with this module.
937              
938             =head1 DEPENDENCIES
939              
940             =over
941              
942             L<perl 5.010|perl/5.10.0>
943              
944             L<utf8>
945              
946             L<version>
947              
948             L<Moose>
949              
950             L<MooseX::StrictConstructor>
951              
952             L<MooseX::HasDefaults::RO>
953              
954             L<MooseX::Types::Moose>
955              
956             L<Text::CSV_XS>
957              
958             L<File::Copy> - copy
959              
960             L<File::Temp>
961              
962             L<Carp> - confess cluck
963              
964             L<Fcntl> - :flock LOCK_EX LOCK_UN SEEK_END
965              
966             =back
967              
968             =cut
969              
970             #########1#########2 main pod documentation end 5#########6#########7#########8#########9