minor fixes to gsheet
[migration-tools.git] / text / clean_csv
1 #!/usr/bin/perl -w
2 use Storable;
3 use Switch;
4 use Getopt::Long;
5 use Text::CSV_XS;
6 use Text::CSV::Separator qw(get_separator);
7 use Data::Dumper;
8 use Term::ANSIColor;
9
10 # may be manipulated with --config
11 our %CSV_options = (
12     binary => 1,
13     auto_diag => 1,
14     diag_verbose => 1,
15 );
16 my $csv;
17 our $fixes = {
18         'R' => [],
19         'I' => [],
20         'D' => []
21 };
22 my @parsed_rows;
23 my @lines_with_errors = ();
24 my %line_numbers_for_lines_with_errors = ();
25 my $expected_column_count;
26 my $line_no;
27
28 # GetOpt variables
29 my $config;
30 my $id_cols;
31 my $fix;
32 my $nosave;
33 my $apply;
34 my $pad;
35 my $truncate;
36 my $backslash;
37 my $debug;
38 my $help;
39 my $create_headers;
40 my $headers_file;
41 my @headers = ();
42
43 my $pad_count = 0; my $trunc_count = 0; my $fix_count = 0; my $backslash_count = 0;
44
45 ################################################################## Subs
46
47 sub format_for_display {
48         my $formatted_line = shift;
49         my $sep_char = $CSV_options{sep_char} || '\t';
50         my $sep = color 'bold blue';
51         $sep .= '<' . (ord($sep_char) < 32 ? ord($sep_char) : $sep_char) . '>';
52         $sep .= color 'reset';
53         my $quote_char = $CSV_options{quote_char} || '';
54         my $quote = color 'bold red';
55         $quote .= '<' . (ord($quote_char) < 32 ? ord($quote_char) : $quote_char) . '>';
56         $quote .= color 'reset';
57         my $escape_char = $CSV_options{escape_char} || '';
58         my $escape = color 'bold green';
59         $escape .= '<' . (ord($escape_char) < 32 ? ord($escape_char) : $escape_char) . '>';
60         $escape .= color 'reset';
61         my $real_escape_char = chr(27);
62         my $real_escape = color 'bold green';
63         $real_escape .= '<27>';
64         $real_escape .= color 'reset';
65
66         $formatted_line =~ s/$real_escape_char/$real_escape/g;
67         $formatted_line =~ s/$sep_char/$sep/g;
68         $formatted_line =~ s/$quote_char/$quote/g;
69         $formatted_line =~ s/$escape_char/$escape/g;
70         for (my $i = 0; $i < 32; $i++) {
71                 if ($i == 27) { next; }
72                 my $other_char = chr($i);
73                 my $other = color 'yellow';
74                 $other .= "<$i>";
75                 $other .= color 'reset';
76                 $formatted_line =~ s/$other_char/$other/g;
77         }
78         return "$formatted_line\n";
79 }
80
81 sub combine_cols {
82         my $row = shift;
83     my $status = $csv->combine(@{ $row });
84     if ($status && $csv->string) {
85         return $csv->string . "\n";
86     } else {
87         die $csv->error_input . "\n";
88     }
89 }
90
91 sub convert_backslashes {
92         my $line = shift;
93         my $altered_line;
94         my @count = $line =~ /\\/g;
95         if (scalar(@count) > 0) {
96                 my $csv2 = Text::CSV_XS->new(\%CSV_options);
97                 if ($csv2->parse($line)) {
98                         my @columns = $csv2->fields();
99                         foreach my $c (@columns) {
100                                 if ($c ne '\N') {
101                                         $c =~ s/\\/\//g;
102                                 }
103                         }
104                         $altered_line = combine_cols(\@columns);
105                 } else {
106                         $altered_line =~ s/\\/\//g;
107                 }
108                 if ($line ne $altered_line) {
109                         $backslash_count += scalar(@count);
110                         print "\nline#$line_no>> Converting " . scalar(@count) . " backslashes to forward slashes\n";
111                         print "before: " . format_for_display($line);
112                         $line = $altered_line;
113                         print " after: " . format_for_display($line);
114                 }
115         }
116         return $line;
117 }
118
119 sub apply_line_fixes {
120         my $line = shift;
121         foreach my $fix ( @{$fixes->{'R'}} ) {
122                 my $id_regex = $fix->[0];
123                 if ($line =~ /$id_regex/) {
124                         print "\nline#$line_no>> Applying regex fix for $id_regex\n";
125                         $fix_count++;
126                         my $regex1 = $fix->[1];
127                         my $regex2 = $fix->[2];
128                         my $global = $fix->[3];
129                         my $ignore_case = $fix->[4];
130                         print "before: " . format_for_display($line);
131                         $line = fix_via_regex($id_regex,$line,$regex1,$regex2,$global,$ignore_case);
132                         print " after: " . format_for_display($line);
133                 }
134         }
135         return $line;
136 }
137
138 sub apply_insert_fixes {
139         my $line = shift;
140         my $cols = shift;
141         foreach my $fix ( @{$fixes->{'I'}} ) {
142                 my $id_regex = $fix->[0];
143                 my $col_count_check = $fix->[1];
144                 if ($line =~ /$id_regex/ && scalar(@{$cols}) eq $col_count_check) {
145                         print "\nline#$line_no>> Applying insert for $id_regex\n";
146                         $fix_count++;
147                         my $fix_cols = $fix->[2];
148                         my $fix_value = $fix->[3];
149                         print "before: " . format_for_display($line);
150                         $line = fix_via_insert($id_regex,$cols,$col_count_check,$fix_cols,$fix_value);
151                         print " after: " . format_for_display($line);
152                 }
153         }
154         return $line;
155 }
156
157 sub apply_delete_fixes {
158         my $line = shift;
159         my $cols = shift;
160         foreach my $fix ( @{$fixes->{'D'}} ) {
161                 my $id_regex = $fix->[0];
162                 my $col_count_check = $fix->[1];
163                 if ($line =~ /$id_regex/ && scalar(@{$cols}) eq $col_count_check) {
164                         print "\nline#$line_no>> Applying delete for $id_regex\n";
165                         $fix_count++;
166                         my $fix_cols = $fix->[2];
167                         print "before: " . format_for_display($line);
168                         $line = fix_via_delete($id_regex,$cols,$col_count_check,$fix_cols);
169                         print " after: " . format_for_display($line);
170                 }
171         }
172         return $line;
173 }
174
175 sub apply_join_fixes {
176         my $line = shift;
177         my $cols = shift;
178         foreach my $fix ( @{$fixes->{'J'}} ) {
179                 my $id_regex = $fix->[0];
180                 my $col_count_check = $fix->[1];
181                 if ($line =~ /$id_regex/ && scalar(@{$cols}) eq $col_count_check) {
182                         print "\nline#$line_no>> Applying join for $id_regex\n";
183                         $fix_count++;
184                         my $fix_cols = $fix->[2];
185                         print "before: " . format_for_display($line);
186                         $line = fix_via_join($id_regex,$cols,$col_count_check,$fix_cols);
187                         print " after: " . format_for_display($line);
188                 }
189         }
190         return $line;
191 }
192
193 sub save_fix {
194         print "saving fix...";
195         my $type = shift;
196         my $fix = shift;
197         if ($nosave) { print "psyche!\n"; return; }
198         print "fix = " . Dumper($fix) . "\n" if $debug;
199         push @{$fixes->{$type}}, $fix;
200         store $fixes, $ARGV[0] . '.fixes';
201         print "saved\n";
202 }
203
204 sub id_cols_regex {
205         my $cols = shift;
206         my @f = sort(split /,/, $id_cols || '0');
207         my $regex = '';
208         for (my $i = 0; $i < scalar(@f); $i++) {
209                 if ($i > 0) {
210                         $regex .= '.+'; # characters between id columns
211                 }
212                 $regex .= '.?' . $cols->[$f[$i]] . '.?';
213         }
214         $regex .= '';
215         return $regex;
216 }
217
218 sub fix_via_regex {
219         my $id_regex = shift;
220         my $line = shift;
221         my $fix_regex1 = shift;
222         my $fix_regex2 = shift;
223         my $global = shift;
224         my $ignore_case = shift;
225         my $save;
226
227         if (!$fix_regex1) {
228 global_prompt:
229                 print "Global (aka s/match/replace/g)? <Yes/No> [n] ";
230                 $global = readline(STDIN); chomp $global;
231                 $global = uc(substr($global,0,1));
232                 if ($global eq '') {
233                         $global = 'N';
234                 }
235                 $global = uc(substr($global,0,1));
236                 if ($global ne 'Y' && $global ne 'N') {
237                         goto global_prompt;
238                 }
239 case_prompt:
240                 print "Ignore-case (aka s/match/replace/i)? <Yes/No> [n] ";
241                 $ignore_case = readline(STDIN); chomp $ignore_case;
242                 $ignore_case = uc(substr($ignore_case,0,1));
243                 if ($ignore_case eq '') {
244                         $ignore_case = 'N';
245                 }
246                 $ignore_case = uc(substr($ignore_case,0,1));
247                 if ($ignore_case ne 'Y' && $ignore_case ne 'N') {
248                         goto case_prompt;
249                 }
250
251 regex1_prompt:
252                 print "Enter match regex for s/match/replace/: ";
253                 $fix_regex1 = readline(STDIN); chomp $fix_regex1;
254                 if ($fix_regex1 eq '') {
255                         goto global_prompt;
256                 }
257                 if (
258                         ($global eq 'Y' && $ignore_case eq 'Y' && $line =~ /$fix_regex1/gi) 
259                         || ($global eq 'Y' && $ignore_case eq 'N' && $line =~ /$fix_regex1/g) 
260                         || ($global eq 'N' && $ignore_case eq 'N' && $line =~ /$fix_regex1/i) 
261                 ) {
262                         print "Regex matches line.\n";
263                 } else {
264                         print "Regex does not match line.\n";
265                         goto regex1_prompt;
266                 }
267 regex2_prompt:
268                 print "Enter replace regex for s/match/replace/: ";
269                 $fix_regex2 = readline(STDIN); chomp $fix_regex2;
270                 if (substr($fix_regex1,-1) eq '$') {
271                         print "Adding new line to end of /$fix_regex2/ based on \$ in /$fix_regex1/\n";
272                         $fix_regex2 .= "\n";
273                 }
274                 # TODO - how to do we handle backreferences with this?
275                 $save = 1;
276         }
277
278         switch ($global . $ignore_case) {
279                 case 'YY'       { $line =~ s/$fix_regex1/$fix_regex2/gi; }
280                 case 'YN'       { $line =~ s/$fix_regex1/$fix_regex2/g; }
281                 case 'NY'       { $line =~ s/$fix_regex1/$fix_regex2/i; }
282                 case 'NN'       { $line =~ s/$fix_regex1/$fix_regex2/; }
283         }
284
285         if ($save) {
286                 save_fix('R',[
287                         $id_regex,
288                         $fix_regex1,
289                         $fix_regex2,
290                         $global,
291                         $ignore_case
292                 ]);
293         }
294
295         return $line;
296 }
297
298 sub fix_via_insert {
299         my $id_regex = shift;
300         my $cols = shift;
301         my $col_count_check = shift;
302         my $fix_cols = shift;
303         my $fix_value = shift;
304         my $line;
305         my $save;
306
307         if (!$fix_cols) {
308                 $col_count_check = scalar(@{$cols});
309                 print "This fix will only trigger when the number of columns is $col_count_check.\n";
310                 print "Enter value to insert: [] ";
311                 $fix_value = readline(STDIN); chomp $fix_value;
312                 print "Enter comma-separated list of column positions (0-based) for insertion: ";
313                 $fix_cols = readline(STDIN); chomp $fix_cols;
314                 $save = 1;
315         }
316
317         if ($col_count_check != scalar(@{$cols})) {
318                 print "WARNING: Insert column fix with ID regex $id_regex expected $col_count_check but found " . scalar(@{$cols}) . ".  Skipping.\n";
319                 return $line;
320         }
321         
322         my @f = sort(split /,/, $fix_cols);
323         for (my $i = 0; $i < scalar(@f); $i++) {
324                 splice @{ $cols }, $f[$i] + $i, 0, $fix_value;
325         }
326
327         eval {
328                 $line = combine_cols($cols);
329         };
330         if ($@) {
331                 print "fix_via_insert error:\n";
332                 die $@;
333         }
334
335         if ($save) {
336                 save_fix('I',[
337                         $id_regex,
338                         $col_count_check,
339                         $fix_cols,
340                         $fix_value
341                 ]);
342         }
343
344         return $line;
345 }
346
347 sub fix_via_delete {
348         my $id_regex = shift;
349         my $cols = shift;
350         my $col_count_check = shift;
351         my $fix_cols = shift;
352         my $line;
353         my $save;
354
355         if (!$fix_cols) {
356                 $col_count_check = scalar(@{$cols});
357                 print "This fix will only trigger when the number of columns is $col_count_check.\n";
358                 print "Enter comma-separated list of column positions (0-based) to delete: ";
359                 $fix_cols = readline(STDIN); chomp $fix_cols;
360                 $save = 1;
361         }
362
363         if ($col_count_check != scalar(@{$cols})) {
364                 print "WARNING: Delete column fix with ID regex $id_regex expected $col_count_check but found " . scalar(@{$cols}) . ".  Skipping.\n";
365                 return $line;
366         }
367         
368         my @f = sort(split /,/, $fix_cols);
369         for (my $i = 0; $i < scalar(@f); $i++) {
370                 splice @{ $cols }, $f[$i] - $i, 1;
371         }
372
373         eval {
374                 $line = combine_cols($cols);
375         };
376         if ($@) {
377                 print "fix_via_delete error:\n";
378                 die $@;
379         }
380
381         if ($save) {
382                 save_fix('D',[
383                         $id_regex,
384                         $col_count_check,
385                         $fix_cols
386                 ]);
387         }
388
389         return $line;
390 }
391
392 sub fix_via_join {
393         my $id_regex = shift;
394         my $cols = shift;
395         my $col_count_check = shift;
396         my $fix_cols = shift;
397         my $line;
398         my $save;
399
400         if (!$fix_cols) {
401                 $col_count_check = scalar(@{$cols});
402                 print "This fix will only trigger when the number of columns is $col_count_check.\n";
403                 print "Enter comma-separated list of column positions (0-based) to join: ";
404                 $fix_cols = readline(STDIN); chomp $fix_cols;
405                 $save = 1;
406         }
407
408         if ($col_count_check != scalar(@{$cols})) {
409                 print "WARNING: Join column fix with ID regex $id_regex expected $col_count_check but found " . scalar(@{$cols}) . ".  Skipping.\n";
410                 return $line;
411         }
412
413         # gather
414         my $fix_value = '';
415         my @f = sort { $a <=> $b } (split /,/, $fix_cols);
416         for (my $i = 0; $i < scalar(@f); $i++) {
417                 $fix_value .= @{ $cols }[$f[$i]];
418         }
419
420         # delete        
421         for (my $i = 0; $i < scalar(@f); $i++) {
422                 splice @{ $cols }, $f[$i] - $i, 1;
423         }
424
425         # insert
426         splice @{ $cols }, $f[0], 0, $fix_value;
427
428         eval {
429                 $line = combine_cols($cols);
430         };
431         if ($@) {
432                 print "fix_via_join error:\n";
433                 die $@;
434         }
435
436         if ($save) {
437                 save_fix('J',[
438                         $id_regex,
439                         $col_count_check,
440                         $fix_cols
441                 ]);
442         }
443
444         return $line;
445 }
446
447
448 sub manual_fix {
449         my $line = shift;
450         my $cols = shift;
451         my $insert_delete_allowed = shift;
452         my $col_count = scalar(@{$cols}) > scalar(@headers) ? scalar(@{$cols}) : scalar(@headers);
453         my $max_header_length = 0;
454
455         # display columns nice and formatted
456         for (my $i = 0; $i < scalar(@headers); $i++) {
457                 if (length($headers[$i]) > $max_header_length) {
458                         $max_header_length = length($headers[$i]);
459                 }
460         }
461         for (my $i = 0; $i < $col_count; $i++) {
462                 printf "#% d ", $i;
463                 if (defined $headers[$i]) {
464                         print " " x ($max_header_length - length($headers[$i]));
465                         print $headers[$i];
466                 } else {
467                         print " " x $max_header_length;
468                 }
469                 print ": ";
470                 if (defined $cols->[$i]) {
471                         print "<" . $cols->[$i] . ">";
472                 }
473                 print "\n";
474         }
475
476         # prompt for type of fix
477 fix_prompt:
478         print "\n" . format_for_display($line) . "\nFix line#$line_no? <Regex" . ($insert_delete_allowed ? '|Insert|Delete|Join' : '') . "|No> [n] ";
479         my $ans = readline(STDIN); chomp $ans;
480         $ans = uc(substr($ans,0,1));
481         if ($ans eq '') {
482                 $ans = 'N';
483         }
484         if ($insert_delete_allowed ? index("RIDJN",$ans)==-1 : index("RN",$ans)==-1) {
485                 goto fix_prompt;
486         }
487
488         # prompt for matching condition
489         my $id_regex;
490         if ($ans ne 'N') {
491                 my $default_id_regex = id_cols_regex($cols);
492 match_prompt:
493                 print "If matching the end of the string, you may need to use \\s*\$ instead of \$\n";
494                 print "Insert/Delete/Join fixes will also filter on column count.\n";
495                 print "Identify this line (and optionally similar lines) with regex: [$default_id_regex] ";
496                 $id_regex = readline(STDIN); chomp $id_regex;
497                 if ($id_regex eq '') {
498                         $id_regex = $default_id_regex;
499                 }
500                 if ($line =~ /$id_regex/) {
501                         print "Regex matches line.\n";
502                 } else {
503                         print "Regex does not match line.\n";
504                         goto match_prompt;
505                 }
506         }
507
508         # prompt and perform actual fixes
509         switch($ans) {
510                 case 'R'        { $line = fix_via_regex($id_regex,$line); }
511                 case 'I'        { $line = fix_via_insert($id_regex,$cols); }
512                 case 'D'        { $line = fix_via_delete($id_regex,$cols); }
513                 case 'J'        { $line = fix_via_join($id_regex,$cols); }
514                 case 'N'        { }
515                 else            { $ans = 'N'; }
516         }
517
518         if ($ans ne 'N') {
519                 print "\nNew line#$line_no: $line";
520         }
521         return ( $ans, $line );
522 }
523
524 ################################################################## Init
525 GetOptions(
526         'config=s' => \$config,
527         'idcols=s' => \$id_cols,
528         'create-headers' => \$create_headers,
529         'use-headers=s' => \$headers_file,
530         'fix' => \$fix,
531         'nosave' => \$nosave,
532         'apply' => \$apply,
533         'pad' => \$pad,
534         'truncate' => \$truncate,
535         'backslash' => \$backslash,
536         'debug' => \$debug,
537         'help|?' => \$help
538 );
539 if ($help || ((@ARGV == 0) && (-t STDIN))) {
540         die "\n\t$0 [--config <CONFIG>] [--idcols <idx1,idx2,...>] [--fix] [--apply] [--pad] [--truncate] <FILE>\n\n"
541                 . "\tExpects <FILE> to be a CSV-like UTF-8 encoded file.\n"
542                 . "\tWill produce <FILE>.clean and <FILE>.error versions of said file.\n\n"
543                 . "\t--config <CONFIG> will read the Perl file <CONFIG> for settings information.  See 'Example Config' below\n\n"
544                 . "\t--create-headers will generate headers like so: col1, col2, col3, etc.\n"
545                 . "\t--use-headers <HFILE> will generate headers based on the specified <HFILE>, which must contain one column header per line.\n"
546                 . "\t(if neither --create-headers nor --use-headers are specified, then the first line in <FILE> is assumed to contain the column headers)\n\n"
547                 . "\t--fix will prompt for whether and how to fix broken records, and save those fixes in <FILE>.fixes\n"
548                 . "\t--idcols <idx1,idx2,...> takes a comma-separated list of column indexes (starting with 0) to use as matchpoint suggestions for fixes\n"
549                 . "\t--nosave will prevent new fixes from being saved in <FILE>.fixes\n"
550                 . "\t--apply will apply previously recorded fixes from <FILE>.fixes\n\n"
551                 . "\t--pad will fill in missing columns at the end if needed for otherwise unbroken records\n"
552                 . "\t--truncate will strip extra columns from the end if needed for otherwise unbroken records\n"
553                 . "\t--backslash will convert backslashes into forward slashes\n\n"
554                 . "\t Example Config:\n\n"
555                 . "\t\t\$CSV_options{quote_char} = '\"';\n"
556                 . "\t\t\$CSV_options{escape_char} = '\"';\n"
557                 . "\t\t\$CSV_options{sep_char} = ',';\n"
558                 . "\t\t\$CSV_options{eol} = \$\\;\n"
559                 . "\t\t\$CSV_options{always_quote} = 0;\n"
560                 . "\t\t\$CSV_options{quote_space} = 1;\n"
561                 . "\t\t\$CSV_options{quote_null} = 1;\n"
562                 . "\t\t\$CSV_options{quote_binary} = 1;\n"
563                 . "\t\t\$CSV_options{binary} = 0;\n"
564                 . "\t\t\$CSV_options{decode_utf8} = 1;\n"
565                 . "\t\t\$CSV_options{keep_meta_info} = 0;\n"
566                 . "\t\t\$CSV_options{allow_loose_quotes} = 0;\n"
567                 . "\t\t\$CSV_options{allow_loose_escapes} = 0;\n"
568                 . "\t\t\$CSV_options{allow_unquoted_escape} = 0;\n"
569                 . "\t\t\$CSV_options{allow_whitespace} = 0;\n"
570                 . "\t\t\$CSV_options{blank_is_undef} = 0;\n"
571                 . "\t\t\$CSV_options{empty_is_undef} = 0;\n"
572                 . "\t\t\$CSV_options{verbatim} = 0;\n"
573                 . "\n\n";
574 }
575 if (! -e $ARGV[0]) {
576         die "$ARGV[0] does not exist\n";
577 }
578 if ($config && ! -e $config) {
579         die "$config does not exist\n";
580 }
581 if ($apply && -e $ARGV[0] . '.fixes') {
582         $fixes = retrieve($ARGV[0] . '.fixes');
583 }
584
585 ################################################################## CSV Setup
586 $CSV_options{sep_char} = get_separator( path => $ARGV[0], lucky => 1 );
587 if ($config && -e $config) {
588         do $config;
589 }
590 $csv = Text::CSV_XS->new(\%CSV_options);
591 $csv->callbacks(
592     error => sub {
593         my ($err, $msg, $pos, $recno) = @_;
594         return if ($err == 2012);
595                 $line_numbers_for_lines_with_errors{$line_no} = 1;
596         print "\nline#$line_no * $err : $msg -> (pos#$pos,rec#$recno)\n";
597         if ($csv->error_input) {
598             print $csv->error_input;
599             print "-" x ($pos - 1);
600             print "^\n";
601         }
602         $csv->SetDiag(0);
603         return;
604     }
605 );
606
607 ################################################################## Reading
608
609 if ($headers_file) {
610         print "_.,-~= reading $headers_file\n";
611         open my $hfile, "<:encoding(utf8)", $headers_file or die "$headers_file: $!";
612         while (my $line = <$hfile>) {
613                 chomp $line;
614                 $line =~ s/\s+$//;
615                 $line =~ s/^\s+//;
616                 push @headers, $line;
617         }
618         close $hfile;
619         $expected_column_count = scalar(@headers);
620         print "Expected column count set to $expected_column_count based on headers.\n";
621 }
622
623 print "_.,-~= reading $ARGV[0]\n";
624 open my $in, "<:encoding(utf8)", $ARGV[0] or die "$ARGV[0]: $!";
625 $line_no = 1; 
626 while (my $line = <$in>) {
627         print ">>> main loop (#$line_no): $line" if $debug;
628         if ($backslash) {
629                 $line = convert_backslashes($line);
630         }
631         if ($apply) {
632                 $line = apply_line_fixes($line);
633         }
634         if ($csv->parse($line)) {
635                 my @columns = $csv->fields();
636                 if (! $expected_column_count) {
637                         $expected_column_count = scalar(@columns);
638                         print "Expected column count set to $expected_column_count based on first row.\n";
639                         for (my $i = 0; $i < scalar(@columns) ; $i++) {
640                                 if ($create_headers) {
641                                         push @headers, "col" . ($i+1);
642                                 } else {
643                                         push @headers, $columns[$i];
644                                 }
645                         }
646                 }
647                 if (defined $line_numbers_for_lines_with_errors{$line_no}) {
648                         if ($fix) {
649                                 my $fix_status;
650                                 ($fix_status,$line) = manual_fix($line,\@columns,0); # Regex only
651                                 if ($fix_status ne 'N') {
652                                         delete $line_numbers_for_lines_with_errors{$line_no};
653                                         $fix_count++;
654                                         redo;
655                                 }
656                         }
657                 } else {
658                         if (scalar(@columns) < $expected_column_count) {
659                                 if ($apply) {
660                                         my $new_line = apply_insert_fixes($line,\@columns);
661                                         if ($line ne $new_line) {
662                                                 $line = $new_line;
663                                                 redo;
664                                         }
665                                 }
666                                 if ($pad) {
667                                         $pad_count++;
668                                         print "\nline#$line_no>> padding line, from " . scalar(@columns) . " columns ";
669                                         my $col_count = scalar(@columns);
670                                         for (my $i = 0; $i < $expected_column_count - $col_count; $i++) {
671                                                 push @columns, '#pad#';
672                                         }
673                                         print "to " . scalar(@columns) . " columns.\n";
674                                         eval {
675                                                 print "before: " . format_for_display($line);
676                                                 $line = combine_cols(\@columns);
677                                                 print " after: " . format_for_display($line);
678                                         };
679                                         if ($@) {
680                                                 print "padding error:\n";
681                                                 die $@;
682                                         }
683                                         redo;
684                                 }
685                         }
686                         if (scalar(@columns) > $expected_column_count) {
687                                 if ($apply) {
688                                         my $new_line = apply_delete_fixes($line,\@columns);
689                                         if ($line ne $new_line) {
690                                                 $line = $new_line;
691                                                 redo;
692                                         }
693                                         $new_line = apply_join_fixes($line,\@columns);
694                                         if ($line ne $new_line) {
695                                                 $line = $new_line;
696                                                 redo;
697                                         }
698                                 }
699                                 if ($truncate) {
700                                         $trunc_count++;
701                                         print "\nline#$line_no>> truncating line, from " . scalar(@columns) . " columns ";
702                                         splice @columns, $expected_column_count;
703                                         print "to " . scalar(@columns) . " columns.\n";
704                                         eval {
705                                                 print "before: " . format_for_display($line);
706                                                 $line = combine_cols(\@columns);
707                                                 print " after: " . format_for_display($line);
708                                         };
709                                         if ($@) {
710                                                 print "truncating error:\n";
711                                                 die $@;
712                                         }
713                                         redo;
714                                 }
715                         }
716                         if (scalar(@columns) != $expected_column_count) {
717                                 # so broken, but parseable, and thus not handled by the error callback
718                                 print "\nline#$line_no * Expected $expected_column_count columns but found " . scalar(@columns) . "\n$line";
719                                 print "-" x length($line) . "\n";
720                                 $line_numbers_for_lines_with_errors{$line_no} = 1;
721                                 if ($fix) {
722                                         my $fix_status;
723                                         ($fix_status,$line) = manual_fix($line,\@columns,1); # Insert/Delete allowed
724                                         if ($fix_status ne 'N') {
725                                                 delete $line_numbers_for_lines_with_errors{$line_no};
726                                                 $fix_count++;
727                                                 redo;
728                                         }
729                                 }
730                         }
731                 }
732                 if (defined $line_numbers_for_lines_with_errors{$line_no}) {
733                         print "\tIncrementing errors with line# $line_no\n" if $debug;
734                         push @lines_with_errors, $line;
735                 } else {
736                         print "\tIncrementing clean with line# $line_no\n" if $debug;
737                         push @parsed_rows, \@columns;
738                 }
739                 $line_no++;
740         } else {
741                 die "Parsing error:\n" . $csv->error_input . "\n";
742         }
743 }
744 close $in;
745 print "_.,-~= read " . ($line_no-1) . " records ";
746 print "(" . scalar(@lines_with_errors) . " with errors, $pad_count auto-padded, $trunc_count auto-truncated, $backslash_count backslashes converted, $fix_count manual fixes)\n";
747
748
749 ################################################################## Writing good CSV
750
751 print "_.,-~= writing $ARGV[0].clean\n";
752 open my $out, ">:encoding(utf8)", "$ARGV[0].clean" or die "$ARGV[0].clean: $!";
753 $line_no = 1;
754 $actual_count = 0;
755 if ($create_headers || $headers_file) {
756         unshift @parsed_rows, \@headers;
757 }
758 foreach my $row (@parsed_rows) {
759         eval {
760                 $line = combine_cols($row);
761                 print $out $line;
762         };
763         if ($@) {
764                 print "error:\n";
765                 die $@;
766         }
767         $actual_count++;
768 }
769 close $out;
770 print "_.,-~= wrote " . ($actual_count) . " records\n";
771
772
773 ################################################################## Writing broken CSV
774
775 print "_.,-~= writing $ARGV[0].error\n";
776 open my $out2, ">:encoding(utf8)", "$ARGV[0].error" or die "$ARGV[0].error: $!";
777 foreach my $row (@lines_with_errors) {
778         print $out2 $row;
779 }
780 close $out2;
781 print "_.,-~= wrote " . (scalar @lines_with_errors) . " records\n";
782
783
784 ################################################################## .no_headers version
785
786 print "_.,-~= creating $ARGV[0].clean.no_headers\n";
787
788 print `tail -n +2 $ARGV[0].clean > $ARGV[0].clean.no_headers`;
789
790 ################################################################## Finished
791
792 print "_.,-~= finished\n";