File Coverage

lib/Log/Shiras/Report/CSVFile.pm
Criterion Covered Total %
statement 179 182 98.3
branch 46 60 76.6
condition 5 6 83.3
subroutine 26 26 100.0
pod 1 3 33.3
total 257 277 92.7


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