File Coverage

blib/lib/Tie/Handle/CSV.pm

Criterion	Covered	Total	%
statement	128	128	100.0
branch	49	50	98.0
condition	13	14	92.8
subroutine	19	19	100.0
pod	2	2	100.0
total	211	213	99.0

package Tie::Handle::CSV;

use 5.006;
use strict;
use warnings;

use Carp;
use Symbol;
use Scalar::Util;
use Text::CSV_XS;

use Tie::Handle::CSV::Hash;
use Tie::Handle::CSV::Array;

our $VERSION = '0.15';

sub new
   {
   my $class = shift;
   my $self  = bless gensym(), $class;
   tie *$self, $self;
   $self->_open(@_);
   return $self;
   }

sub TIEHANDLE
   {
   return $_[0] if ref $_[0];
   my $class = shift;
   return $class->new(@_);
   }

sub _open
   {
   my ($self, @opts) = @_;

   my ($file, %opts, $csv_fh);

   ## if an odd number of options are given,
   ## assume the first arg is the file name
   if (@opts % 2)
      {
      $file = shift @opts;
      %opts = @opts;
      $opts{'file'} = $file;
      }
   else
      {
      %opts = @opts;
      }

   ## support old 'openmode' option key
   if ( exists $opts{'openmode'} && ! exists $opts{'open_mode'} )
      {
      $opts{'open_mode'} = $opts{'openmode'};
      }

   ## support old 'stringify' option key
   if ( exists $opts{'stringify'} && ! exists $opts{'simple_reads'} )
      {
      $opts{'simple_reads'} = ! $opts{'stringify'};
      }

   my $file_ref_type = Scalar::Util::reftype( $opts{'file'} ) || '';

   if ( $file_ref_type eq 'GLOB' )
      {
      $csv_fh = $opts{'file'};
      }
   else
      {

      ## use 3-arg open if 'open_mode' is specified,
      ## otherwise use 2-arg to work with STDIN via '-'
      if ( defined $opts{'open_mode'} )
         {
         open( $csv_fh, $opts{'open_mode'}, $opts{'file'} )
            || croak "$!: $opts{'file'}";
         }
      else
         {
         open( $csv_fh, $opts{'file'} ) || croak "$!: $opts{'file'}";
         }

      }

   ## establish the csv object
   ## use given sep_char when possible
   if ( $opts{'csv_parser'} )
      {
      if ( ref $opts{'csv_parser'} ne 'Text::CSV_XS' )
         {
         confess "'csv_parser' is not an instance of 'Text::CSV_XS'";
         }
      }
   elsif ( defined $opts{'sep_char'} )
      {
      $opts{'csv_parser'} =
         Text::CSV_XS->new( { sep_char => $opts{'sep_char'}, binary => 1 } );
      }
   else
      {
      $opts{'csv_parser'} = Text::CSV_XS->new( { binary => 1 } );
      }

   $opts{'header'} = 1 unless exists $opts{'header'};

   if ( $opts{'header'} )
      {

      if ( ref $opts{'header'} ne 'ARRAY' )
         {
         my $header_line = <$csv_fh>;
         $opts{'csv_parser'}->parse($header_line)
            || croak $opts{'csv_parser'}->error_input();
         $opts{'header'} = [ $opts{'csv_parser'}->fields() ];
         }

      $opts{'orig_header'} = [ @{ $opts{'header'} } ];

      ## support old 'force_lower' option key
      if ( $opts{'force_lower'} && ! $opts{'key_case'} )
         {
         $opts{'key_case'} = 'lower';
         }

      if ( $opts{'key_case'} )
         {

         if ( lc $opts{'key_case'} eq 'lower' )
            {
            for my $header ( @{ $opts{'header'} } )
               {
               $header = lc $header;
               }
            }
         elsif ( lc $opts{'key_case'} eq 'upper' )
            {
            for my $header ( @{ $opts{'header'} } )
               {
               $header = uc $header;
               }
            }

         }

      }

   *$self->{handle} = $csv_fh;
   *$self->{opts}   = \%opts;
   }

sub READLINE
   {
   my ($self) = @_;

   my $opts = *$self->{'opts'};

   if (wantarray)
      {

      my @parsed_lines;

      while (my $parsed_line = $self->READLINE)
         {
         push @parsed_lines, $parsed_line;
         }

      return @parsed_lines;

      }
   else
      {
      my $cols = $opts->{'csv_parser'}->getline(*$self->{'handle'});
      if (defined $cols)
         {
         if ( $opts->{'header'} )
            {
            my $parsed_line;

            if ( $opts->{'simple_reads'} )
               {
               @{ $parsed_line }{ @{ $opts->{'header'} } } = @{ $cols };
               }
            else
               {
               $parsed_line = Tie::Handle::CSV::Hash->_new($self);
               $parsed_line->_init_store( $cols );
               }

            return $parsed_line;
            }
         else
            {
            my $parsed_line;

            if ( $opts->{'simple_reads'} )
               {
               @{ $parsed_line } = @{ $cols };
               }
            else
               {
               $parsed_line = Tie::Handle::CSV::Array->_new($self);
               $parsed_line->_init_store( $cols );
               }

            return $parsed_line;
            }
         }

      }

      return;

   }

sub CLOSE
   {
   my ($self) = @_;
   return close *$self->{'handle'};
   }

sub PRINT
   {
   my ($self, @list) = @_;
   my $handle = *$self->{'handle'};
   return print $handle @list;
   }

sub SEEK
   {
   my ($self, $position, $whence) = @_;
   return seek *$self->{'handle'}, $position, $whence;
   }

sub TELL
   {
   my ($self) = @_;
   return tell *$self->{'handle'};
   }

sub header
   {
   my ($self) = @_;
   my $opts   = *$self->{opts};
   my $header = $opts->{orig_header};
   my $parser = $opts->{csv_parser};

   if ( ! $header || ref $header ne 'ARRAY' )
      {
      croak "handle does not contain a header";
      }

   my $header_array = Tie::Handle::CSV::Array->_new($self);
   @{ $header_array } = @{$header};
   return $header_array;
   }

1;

__END__