File Coverage

blib/lib/Text/CSV/Separator.pm

Criterion	Covered	Total	%
statement	126	150	84.0
branch	60	82	73.1
condition	17	24	70.8
subroutine	10	11	90.9
pod	1	1	100.0
total	214	268	79.8

package Text::CSV::Separator;

use 5.008;
use strict;
use warnings;
use Carp qw(carp croak);

our $VERSION = '0.20';

use Exporter;
use base 'Exporter';
our @EXPORT_OK = qw(get_separator);


sub get_separator {

    my %options = @_;

    my $file_path = $options{path};

    # check options
    my $echo;
    if ($options{echo}) {
        $echo = 1;
        print "\nDetecting field separator of $file_path\n";
    }

    my (@excluded, @included);
    if (exists $options{exclude}) {
        @excluded = @{$options{exclude}};
    }

    if (exists $options{include}) {
        @included = @{$options{include}};
    }

    my ($lucky, $colon_timecol, $comma_decsep, $comma_groupsep);
    if (exists $options{lucky} && $options{lucky} == 1) {
        $lucky = 1;
        print "Scalar context...\n\n" if $echo;
    } else {
        $colon_timecol = $comma_decsep = $comma_groupsep = 1;
        print "List context...\n\n" if $echo;
    }

    # options checked

    # Default set of candidates
    my @candidates = (',', ';', ':', '|', "\t");

    my %survivors;
    $survivors{$_} = [] foreach (@candidates);

    if (@excluded > 0) {
        foreach (@excluded) {
            delete $survivors{$_};
            _message('deleted', $_) if $echo;
        }
    }

    if (@included > 0) {
        foreach (@included) {
            if (length($_) == 1) {
                $survivors{$_} = [];
            }
            _message('added', $_) if $echo;
        }
    }

    if (keys %survivors == 0) {
        carp "No candidates left!";
        return;
    }

    my $csv;
    open ($csv, "<:crlf", $file_path) || croak "Couldn't open $file_path: $!";

    my $record_count = 0; # if $echo
    while (<$csv>) {
        my $record = $_;
        chomp $record;

        if ($echo) {
            $record_count++;
            print "\nRecord #$record_count\n";
        }

        foreach my $candidate (keys %survivors) {
            _message('candidate', $candidate) if $echo;

            my $rex = qr/\Q$candidate\E/;

            my $count = 0;
            $count++ while ($record =~ /$rex/g);

            print "Count: $count\n" if $echo;

            if ($count > 0 && !$lucky) {
                push @{$survivors{$candidate}}, $count;
            } elsif ($count == 0) {
                delete $survivors{$candidate};
            }

        }

        if (!$lucky) {
            $colon_timecol = _regularity($record, 'timecol') if $colon_timecol;
            $comma_decsep = _regularity($record, 'decsep') if $comma_decsep;
            $comma_groupsep = _regularity($record, 'groupsep') if $comma_groupsep;
        }


        my @alive = keys %survivors;
        my $survivors_count = @alive;
        if ($survivors_count == 1) {
            if ($echo) {
                _message('detected', $alive[0]);
                print "Returning control to caller...\n\n";
            }
            close $csv;
            if (!$lucky) {
                return @alive;
            } else {
                return $alive[0];
            }
        } elsif ($survivors_count == 0) {
                carp "\nNo candidates left!\n";
                return;
        }
    }

    #  More than 1 survivor. 2nd pass to determine count variability
    if ($lucky) {
        print "\nSeveral candidates left\n" if $echo;
        carp "\nBad luck. Couldn't determine the separator of $file_path.\n";
        return;
    } else {
        print "\nVariability:\n\n" if $echo;
        my %std_dev;
        foreach my $candidate (keys %survivors) {
            my $mean = _mean(@{$survivors{$candidate}});
            $std_dev{$candidate} = _std_dev($mean, @{$survivors{$candidate}});
            if ($echo) {
                _message('candidate', $candidate);
                print "Mean: $mean\tStd Dev: $std_dev{$candidate}\n\n";
            }
        }

        print "Couldn't determine the separator\n" if $echo;

        close $csv;

        my @penalized;
        if ($colon_timecol) {
            print "Detected time column\n" if $echo;
            delete $survivors{':'};
            push @penalized, ':';
        }

        if ($comma_decsep || $comma_groupsep) {
            delete $survivors{','};
            push @penalized, ',';
            if ($echo && $comma_decsep) {
                print "\nDetected comma-separated decimal numbers column\n";
            }
            if ($echo && $comma_groupsep) {
                print "\nDetected comma-grouped numbers column\n";
            }
        }

        my @alive = sort {$std_dev{$a} <=> $std_dev{$b}} keys %survivors;
        push @alive, sort {$std_dev{$a} <=> $std_dev{$b}} @penalized;
        if ($echo) {
            print "Remaining candidates: ";
            foreach my $left (@alive) {
                _message('left', $left);
            }
            print "\n\nReturning control to caller...\n\n";
        }
        return @alive;
    }
}

sub _mean {
    my @array = @_;

    my $sum = 0;
    $sum += $_ foreach (@array);

    my $mean = $sum / scalar(@array);

    return $mean;
}

sub _std_dev {
    my ($mean, @array) = @_;

    my $sum = 0;
    $sum += ($_ - $mean)**2 foreach (@array);

    my $std_dev = sqrt( $sum / scalar(@array) );

    return $std_dev;
}

sub _regularity {
    my ($string, $kind) = @_;

    my $time_rx = qr/
                        (?:^|(?<=\s|[T,;|\t]))
                        (?:[01]?[0-9]|2[0-3])   # hours
                        :
                        (?:[0-5][0-9])          # minutes
                        (?::[0-5][0-9])?        # seconds
                        (?:
                            Z
                            |
                            \.\d+
                            |
                            (?:\+|-)
                            (?:[01]?[0-9]|2[0-3])
                            :
                            (?:[0-5][0-9])
                        )?
                        (?=$|\s|[,;|\t])
                    /x;

    my $commadecsep_rx = qr/
                                (?:^|(?<=[^\d,.]))
                                (?:
                                    [-+]?
                                    (?:
                                        \d{0,3}?(?:\.\d{3})*
                                        |
                                        \d+
                                    )
                                    ,\d+
                                )
                                (?=$|[^\d,.])
                            /x;

    my $commagroupsep_rx = qr/
                                (?:^|(?<=[^\d,.]))
                                (?:
                                    [-+]?\d{0,3}?
                                    (?:,\d{3})+
                                    (?:\.\d+)?
                                )
                                (?=$|[^\d,.])
                             /x;


    return 0 if ($kind eq 'timecol' && $string !~ /$time_rx/);
    return 0 if ($kind eq 'decsep' && $string !~ /$commadecsep_rx/);
    return 0 if ($kind eq 'groupsep' && $string !~ /$commagroupsep_rx/);

    return 1;
}

sub _message {
    my ($type, $candidate) = @_;

    my $char;
    if (ord $candidate == 9) { # tab character
        $char = "\\t";
    } else {
        $char = $candidate;
    }

    my %message = (
                   deleted => "Deleted $char from candidates list\n",
                   added => "Added $char to candidates list\n",
                   candidate => "Candidate: $char\t",
                   detected => "\nSeparator detected: $char\n",
                   left => " $char ",
                  );

    print $message{$type};
}

1;

__END__