File Coverage

blib/lib/Text/xSV.pm

Criterion	Covered	Total	%
statement	165	230	71.7
branch	81	134	60.4
condition	14	24	58.3
subroutine	27	33	81.8
pod	20	23	86.9
total	307	444	69.1

package Text::xSV;
$VERSION = 0.21;
use strict;
use Carp;

sub alias {
  my ($self, $from, $to) = @_;
  my $field_pos = $self->{field_pos}
    or return $self->error_handler(
      "Can't call alias before headers are bound");
  unless (exists $field_pos->{$from}) {
    return $self->error_handler("'$from' is not available to alias");
  }
  $field_pos->{$to} = $field_pos->{$from};
}

sub add_compute {
  my ($self, $name, $compute) = @_;
  my $field_pos = $self->{field_pos}
    or return $self->error_handler(
      "Can't call add_compute before headers are bound");
  unless (UNIVERSAL::isa($compute, "CODE")) {
    return $self->error_handler(
      'Usage: $csv->add_compute("name", sub {FUNCTION});');
  }
  $field_pos->{$name} = $compute;
}

sub bind_fields {
  my $self = shift;
  my %field_pos;
  foreach my $i (0..$#_) {
    $field_pos{$_[$i]} = $i;
  }
  $self->{field_pos} = \%field_pos;
}

sub bind_header {
  my $self = shift;
  $self->bind_fields($self->get_row());
}

*read_headers = \&bind_header;
*read_header = \&bind_header;

sub delete {
  my $self = shift;
  my $field_pos = $self->{field_pos}
    or return $self->error_handler(
      "Can't call delete before headers are bound");
  foreach my $field (@_) {
    if (exists $field_pos->{$field}) {
      delete $field_pos->{$field};
    }
    else {
      $self->error_handler(
        "Cannot delete field '$field': it doesn't exist");
    }
  }
}

sub error_handler {
  my $self = shift;
  $self->{error_handler}->(@_);
}

sub extract {
  my $self = shift;
  my $cached_results = $self->{cached} ||= {};
  my $in_compute = $self->{in_compute} ||= {};
  my $row = $self->{row} or return $self->error_handler(
    "No row found (did you call get_row())?");
  my $lookup = $self->{field_pos}
    or return $self->error_handler(
      "Can't find field info (did you bind_fields or read_header?)");
  my @data;
  foreach my $field (@_) {
    if (exists $lookup->{$field}) {
      my $position_or_compute = $lookup->{$field};
      if (not ref($position_or_compute)) {
        push @data, $row->[$position_or_compute];
      }
      elsif (exists $cached_results->{$field}) {
        push @data, $cached_results->{$field};
      }
      elsif ($in_compute->{$field}) {
        $self->error_handler(
          "Infinite recursion detected in computing '$field'");
      }
      else {
        # Have to do compute
        $in_compute->{$field} = 1;
        $cached_results->{$field} = $position_or_compute->($self);
        push @data, $cached_results->{$field};
      }
    }
    else {
      my @allowed = sort keys %$lookup;
      $self->error_handler(
        "Invalid field $field for file '$self->{filename}'.\n" .
        "Valid fields are: (@allowed)\n"
      );
    }
  }
  return wantarray ? @data : \@data;
}

sub extract_hash {
  my $self = shift;
  my @fields = @_ ? @_ : $self->get_fields();
  my %hash;
  @hash{@fields} = $self->extract(@fields);
  wantarray ? %hash : \%hash;
}

sub fetchrow_hash {
  my $self = shift;
  return unless $self->get_row();
  $self->extract_hash(@_);
}

sub format_data {
  my $self = shift;
  my %data = @_;
  my @row;
  my $field_pos = $self->{field_pos} or $self->error_handler(
    "Can't find field info (did you bind_fields or read_header?)"
  );
  while (my ($field, $value) = each %data) {
    my $pos = $field_pos->{$field};
    if (defined($pos)) {
      $row[$pos] = $value;
    }
    else {
      $self->warning_handler("Ignoring unknown field '$field'");
    }
  }
  $self->{row} = \@row;
  my $header = $self->{header}
    or $self->error_handler("Cannot format_data when no header is set");
  $self->format_row( $self->extract( @$header ));
}

sub format_header {
  my $self = shift;
  if ($self->{header}) {
    return $self->format_row(@{$self->{header}});
  }
  else {
    $self->error_handler("Cannot format_header when no header is set");
  }
}

*format_headers = \&format_header;

sub format_row {
  my $self = shift;

  $self->{row_num}++;

  if ($self->{row_size_warning}) {
    if (not exists $self->{row_size}) {
      $self->{row_size} = @_;
    }
    elsif ( @_ != $self->{row_size}) {
      my $count = @_;
      $self->warning_handler(
        "Formatting $count fields at row $self->{row_num}, "
        . "expected $self->{row_size}"
      );
    }
  }

  my $sep = $self->{sep};
  my @row;
  foreach my $value (@_) {
    if (not defined($value)) {
      # Empty fields are undef
      push @row, $self->{quote_all} ? qq("") : "";
    }
    elsif ("" eq $value) {
      # The empty string has to be quoted unless dont_quote is set
      push @row, $self->{dont_quote} ? "" : qq{""};
    }
    elsif ($value =~ /\s|\Q$sep\E|"/) {
      # quote it
      local $_ = $value;
      s/"/""/g;
      # If dont_quote is set, just output the data element,
      # otherwise follow the 'proper' CSV quoted format (that breaks
      # MS SQL Server's bulk insert on date values)
      push @row, $self->{dont_quote} ? $_ : qq{"$_"};
    }
    else {
      # Unquoted is fine (that is, unless the quote_all option is set)
      push @row, $self->{quote_all} ? qq("$value") : $value;
    }
  }
  my $row = join $sep, @row;
  return $row . "\n";
}

sub get_fields {
  my $self = shift;
  my $field_pos = $self->{field_pos}
    or return $self->error_handler(
      "Can't call get_fields before headers are bound");
  return keys %$field_pos;
}

# Private block for shared variables in a small "parse engine".
# The concept here is to use pos to step through a string.
# This is the real engine, all else is syntactic sugar.
{
  my ($self, $fh, $line, $is_error);

  sub get_row {
    $self = shift;
    $is_error = 0;
    delete $self->{row};
    delete $self->{cached};
    delete $self->{in_compute};
    $fh = ($self->{fh}
      ||= $self->{filename}
        ? $self->open_file($self->{filename}, "<")
        : ($self->{filename} = "ARGV", \*ARGV)
        # Sorry for the above convoluted way to sneak in defining filename.
    );
    return unless $fh;
    defined($line = <$fh>) or return;
    if ($self->{filter}) {
      $line = $self->{filter}->($line);
    }
    chomp($line);
    my @row = _get_row();
    if ($is_error) {
      return @row[0..$#row];
    }
    if (not exists $self->{row_size}) {
      $self->{row_size} = @row;
    }
    elsif (not $self->{row_size_warning}) {
      # The user asked not to get this warning, so don't issue it.
    }
    elsif ($self->{row_size} != @row) {
      my $new = @row;
      my $where = "Line $., file $self->{filename}";
      $self->warning_handler(
        "$where had $new fields, expected $self->{row_size}" );
    }
    $self->{row} = \@row;
    return wantarray ? @row : [@row];
  }

  sub _get_row {
    my @row;
    my $q_sep = quotemeta($self->{sep});
    my $match_sep = qr/\G$q_sep/;
    my $start_field = qr/\G(")/;
    my $start_field_ms = qr/\G([^"$q_sep]*)/;

    # This loop is the heart of the engine
    while ($line =~ /$start_field/gc or $line =~ /$start_field_ms/gc ) {
      if ($1 eq '"') {
        push @row, _get_quoted();
      }
      else {
        # Needed for Microsoft compatibility
        push @row, length($1) ? $1 : undef;
      }
      my $pos = pos($line);
      if ($line !~ /$match_sep/g) {
        if ($pos == length($line)) {
          return @row;
        }
        elsif ($self->{strict}) {
          my $expected = "Expected '$self->{sep}'";
          $is_error = 1;
          return $self->error_handler(
            "$expected at $self->{filename}, line $., char $pos");
        }
        else {
          TRY: {
            my $expected = "Expected '$self->{sep}'";
            $self->warning_handler(
              "$expected at $self->{filename}, line $., char $pos");

            # Assume we are in non-strict mode and encountered a single "
            # so we need to recover and finish my quoted field.
            $row[-1] .= '"' . _get_quoted();
            $pos = pos($line);
            if ($line !~ /$match_sep/g) {
              if ($pos == length($line)) {
                return @row;
              }
              else {
                redo TRY;
              }
            }
          }
        }
      }
    }
    $is_error = 1;
    $self->error_handler(
      "I have no idea how parsing $self->{filename} left me here!");
  }

  sub _get_quoted {
    my $piece = "";
    my $start_line = $.;
    my $start_pos = pos($line);

    while(1) {
      if ($line =~ /\G([^"]+)/gc) {
        # sequence of non-quote characters
        $piece .= $1;
      } elsif ($line =~ /\G""/gc) {
        # replace "" with "
        $piece .= '"';
      } elsif ($line =~ /\G"/g) {
        # closing quote
        return $piece;  # EXIT HERE
      }
      else {
        # Must be at end of line
        $piece .= $/;
        unless(defined($line = <$fh>)) {
          croak(
            "File $self->{filename} ended inside a quoted field\n"
              . "Field started at char $start_pos, line $start_line\n"
          );
        }
        if ($self->{filter}) {
          $line = $self->{filter}->($line);
        }
        chomp($line);
      }
    }
    $is_error = 1;
    $self->error_handler(
      "I have no idea how parsing $self->{filename} left me here!");
  }
}

my @normal_accessors = qw(
  close_fh error_handler warning_handler filename filter fh
  row_size row_size_warning strict
);
foreach my $accessor (@normal_accessors) {
  no strict 'refs';
  *{"set_$accessor"} = sub {
    $_[0]->{$accessor} = $_[1];
  };
}

# These two are mutually exclusive
foreach my $accessor (qw(dont_quote quote_all)) {
  no strict 'refs';
  *{"set_$accessor"} = sub {
    my $self = shift;
    $self->{$accessor} = shift;
    if ($self->{dont_quote} and $self->{quote_all}) {
      $self->error_handler("Can't set both dont_quote and quote_all");
    }
  };
}

sub new {
  my $self = bless ({}, shift);
  my %allowed = map {
                  $_=>1
                } @normal_accessors, qw(
                  header headers row sep dont_quote quote_all
                );

  my %args = (
    error_handler => \&confess,
    filter => sub {my $line = shift; $line =~ s/\r$//; $line;},
    sep => ",",
    row_size_warning => 1,
    close_fh => 0,
    strict => 1,
    @_
  );
  # Note, must set error_handler and warning_handler first because they
  # might get called while processing the other args.
  foreach my $arg ('error_handler', 'warning_handler', keys %args) {
    unless (exists $allowed{$arg}) {
      my @allowed = sort keys %allowed;
      croak("Invalid argument '$arg', allowed args: (@allowed)");
    }
    my $method = "set_$arg";
    $self->$method($args{$arg});
  }
  return $self;
}

# Note the undocumented third argument for the mode.  Most of the time this
# will do what is wanted without requiring Perl 5.6 or better.  Users who
# supply their own metacharacters will also not be surprised at the result.
# Note the return of 0.  I cannot assume that the user's error handler dies...
sub open_file {
  my $self = shift;
  my $file = $self->{filename} = shift || return $self->error_handler(
    "No filename specified at open_file"
  );
  if ($file !~ /\||<|>/ and @_) {
    my $mode = shift;
    $file = "$mode $file";
  }
  my $fh = do {local *FH}; # Old trick, not needed in 5.6
  unless (open ($fh, $file)) {
    $self->error_handler("Cannot open '$file': $!");
    return 0;
  }
  $self->{close_fh} = 1;
  $self->{fh} = $fh;
}

sub print {
  my $self = shift;
  $self->{row_out}++;
  my $fh = ($self->{fh}
      ||= $self->{filename}
        ? $self->open_file($self->{filename}, ">")
        : ($self->{filename} = "STDOUT", \*STDOUT)
        # Sorry for the above convoluted way to sneak in defining filename.
      );
  return unless $fh;
  print $fh @_ or $self->error_handler( "Print #$self->{row_out}: $!" );
}

sub print_data {
  my $self = shift;
  $self->print($self->format_data(@_));
}

sub print_header {
  my $self = shift;
  $self->print($self->format_header(@_));
}

*print_headers = \&print_header;

sub print_row {
  my $self = shift;
  $self->print($self->format_row(@_));
}

sub set_header {
  my $self = shift;
  if (1 == @_ and UNIVERSAL::isa($_[0], 'ARRAY')) {
    $self->{header} = $_[0];
  }
  else {
    $self->{header} = \@_;
  }
  if (not exists $self->{field_pos}) {
    $self->bind_fields(@{$self->{header}});
  }
}

*set_headers = \&set_header;

sub set_sep {
  my $self = shift;
  my $sep = shift;
  # The reason for this limitation is so that $start_field in _get_row
  # will do what it is supposed to.  (I should use a negative lookahead,
  # but I'm documenting this late at night and want some sleep.)
  if (1 == length($sep)) {
    $self->{sep} = $sep;
  }
  else {
    $self->error_handler("The separator '$sep' is not of length 1");
  }
}

sub warning_handler {
  my $self = shift;
  if ($self->{warning_handler}) {
    $self->{warning_handler}->(@_);
  }
  else {
    eval { $self->{error_handler}->(@_) };
    warn $@ if $@;
  }
}

sub DESTROY {
  my $self = shift;
  if ($self->{close_fh}) {
    close($self->{fh}) or $self->error_handler(
      $! ? "Cannot close '$self->{filename}': $!"
         : "Exit status $? closing '$self->{filename}'"
    );
  }
}

1;

__END__