File Coverage

blib/lib/Text/CSV/Encoded.pm

Criterion	Covered	Total	%
statement	115	119	96.6
branch	51	66	77.2
condition	14	22	63.6
subroutine	23	23	100.0
pod	12	13	92.3
total	215	243	88.4

package Text::CSV::Encoded;
$Text::CSV::Encoded::VERSION = '0.25';
use strict;
use warnings;
use Carp ();

# VERSION


BEGIN {
    require Text::CSV;
    if ( Text::CSV->VERSION < 1.06 ) {
        Carp::croak "Base class Text::CSV version is less than 1.06.";
    }
    my $backend = Text::CSV->backend;
    my $version = Text::CSV->backend->VERSION;
    if ( ( $backend =~ /XS/ and $version >= 0.99 ) or ( $backend =~ /PP/ and $version >= 1.30 ) ) {
        eval q/ sub automatic_UTF8 { 1; } /; # parse/getline return strings (UNICODE)
    }
    else {
        eval q/ sub automatic_UTF8 { 0; } /;
    }
}

use base qw( Text::CSV );


my $DefaultCoderClass = $] >= 5.008 ? 'Text::CSV::Encoded::Coder::Encode'
                                    : 'Text::CSV::Encoded::Coder::Base';
my @Attrs;


BEGIN {
    @Attrs = qw(
        encoding
        encoding_in       encoding_out
        encoding_io_in    encoding_io_out
        encoding_to_parse encoding_to_combine
    );
}


sub import {
    my ( $class, %args ) = @_;

    return unless %args;

    if ( exists $args{ coder_class } ) {
        $DefaultCoderClass = $args{ coder_class };
    }

}


sub new {
    my $class = shift;
    my $opt   = shift || {};
    my %opt;

    $opt->{binary} = 1;

    for my $attr ( @Attrs, 'encoding', 'coder_class' ) {
        $opt{ $attr }  = delete $opt->{ $attr } if ( exists $opt->{ $attr } );
    }

    my $self = $class->SUPER::new( $opt ) || return;

    if ( my $coder_class = ( $opt{coder_class} || $DefaultCoderClass ) ) {
        $self->coder_class( $coder_class );
    }
    else {
        Carp::croak "Coder class is not specified.";
    }

    for my $attr ( @Attrs, 'encoding' ) {
        $self->$attr( $opt{ $attr } ) if ( exists $opt{ $attr } );
    }

    $self;
}


#
# Methods
#

sub combine {
    my $self   = shift;
    my @fields = @_;

    $self->coder->decode_fields_ref( $self->encoding, \@fields ) if ( $self->encoding );

    unless ( $self->encoding_out ) {
        return $self->SUPER::combine( @fields );
    }

    my $ret = $self->encode( $self->encoding_out, \@fields );

    $self->{_STRING} = \$ret if ( $ret );

    return $self->{_STATUS};
}


sub parse {
    my $self = shift;
    my $ret;

    if ( $self->encoding_in ) {
        $ret  = $self->decode( $self->encoding_in, $_[0] );
    }
    else {
        $ret = [ $self->fields ] if $self->SUPER::parse( @_ );
    }

    if ( $ret ) {
        $self->coder->encode_fields_ref( $self->encoding, $ret ) if ( $self->encoding );
        $self->{_FIELDS} = $ret;
    }

    return $self->{_STATUS};
}


#
# IO style
#

sub print { # to CSV
    my ( $self, $io, $cols ) = @_;

    $self->coder->decode_fields_ref( $self->encoding,      $cols ) if ( $self->encoding );
    $self->coder->encode_fields_ref( $self->encoding_out,  $cols );

    $self->SUPER::print( $io, $cols );
}


sub getline { # from CSV
    my ( $self, $io ) = @_;
    my $cols = $self->SUPER::getline( $io );

    if ( my $binds = $self->{_BOUND_COLUMNS} ) {
        for my $val ( @$binds ) {
            $$val = $self->coder->decode( $self->encoding_in, $$val );
            $$val = $self->coder->encode( $self->encoding,    $$val ) if ( $self->encoding );
        }
        return $cols;
    }

    return unless $cols;

    $self->coder->decode_fields_ref( $self->encoding_in, $cols );
    $self->coder->encode_fields_ref( $self->encoding,    $cols ) if ( $self->encoding );

    $cols;
}


#
# decode/encode style
#

sub decode {
    my ( $self, $enc, $text ) = @_;

    if ( @_ == 2 ) {
        $text = $enc, $enc = '';
    }

    $self->coder->upgrade( $text ) unless ( $enc ); # as unicode

    return unless ( defined $text );
    return unless ( $self->SUPER::parse( $text ) );

    return $enc ? [ map { $self->coder->decode( $enc, $_ ) } $self->fields() ] : [ $self->fields() ];
}


sub encode {
    my ( $self, $enc, $array ) = @_;

    if ( @_ == 2 ) {
        $array = $enc, $enc = '';
    }

    return unless ( defined $array and ref $array eq 'ARRAY' );
    return unless ( $self->SUPER::combine ( @$array ) );

    return $enc ? $self->coder->encode( $enc, $self->string() ) : $self->string();
}


# Internal

sub _load_coder_class {
    my ( $class, $coder_class ) = @_;
    (my $file = "$coder_class.pm") =~ s{::}{/}g;

    eval { require $file };

    if ( $@ ) {
        Carp::croak $@;
    }

    $coder_class;
}


# Accessors

BEGIN {
    for my $method ( qw( encoding encoding_in encoding_out ) ) {
        eval qq|
            sub $method {
                my ( \$self, \$encoding ) = \@_;
                if ( \@_ > 1 ) {
                    \$self->{ $method } = \$encoding;
                    return \$self;
                }
                else {
                    \$self->{ $method };
                }
            }
        |;
    }
}


*encoding_io_in  = *encoding_to_parse   = *encoding_in;
*encoding_io_out = *encoding_to_combine = *encoding_out;


sub coder {
    my $self = shift;
    $self->{coder} ||= $self->coder_class->new( automatic_UTF8 => $self->automatic_UTF8, @_ );
}


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

    return $self->{coder_class} if ( @_ == 1 );

    $self->_load_coder_class( $coder_class );
    $self->{coder_class} = $coder_class;
    $self;
}


1;
__END__