File Coverage

blib/lib/Text/CSV/Encoded.pm
Criterion Covered Total %
statement 112 116 96.5
branch 51 66 77.2
condition 12 22 54.5
subroutine 22 22 100.0
pod 12 13 92.3
total 209 239 87.4


line stmt bran cond sub pod time code
1             package Text::CSV::Encoded;
2              
3 13     13   275314 use strict;
  13         30  
  13         398  
4 13     13   71 use vars qw( $VERSION );
  13         27  
  13         701  
5 13     13   65 use Carp ();
  13         26  
  13         1990  
6              
7             $VERSION = '0.23';
8              
9              
10             BEGIN {
11 13     13   10878 require Text::CSV;
12 13 50       191139 if ( Text::CSV->VERSION < 1.06 ) {
13 0         0 Carp::croak "Base class Text::CSV version is less than 1.06.";
14             }
15 13         82 my $backend = Text::CSV->backend;
16 13         105 my $version = Text::CSV->backend->VERSION;
17 13 50 33     352 if ( ( $backend =~ /XS/ and $version >= 0.99 ) or ( $backend =~ /PP/ and $version >= 1.30 ) ) {
      33        
      33        
18 13     12 0 849 eval q/ sub automatic_UTF8 { 1; } /; # parse/getline return strings (UNICODE)
  12         1181  
19             }
20             else {
21 0         0 eval q/ sub automatic_UTF8 { 0; } /;
22             }
23             }
24              
25 13     13   105 use base qw( Text::CSV );
  13         22  
  13         1890  
26              
27              
28             my $DefaultCoderClass = $] >= 5.008 ? 'Text::CSV::Encoded::Coder::Encode'
29             : 'Text::CSV::Encoded::Coder::Base';
30             my @Attrs;
31              
32              
33             BEGIN {
34 13     13   12236 @Attrs = qw(
35             encoding
36             encoding_in encoding_out
37             encoding_io_in encoding_io_out
38             encoding_to_parse encoding_to_combine
39             );
40             }
41              
42              
43             sub import {
44 4     4   2734 my ( $class, %args ) = @_;
45              
46 4 100       3010 return unless %args;
47              
48 1 50       5 if ( exists $args{ coder_class } ) {
49 1         198 $DefaultCoderClass = $args{ coder_class };
50             }
51              
52             }
53              
54              
55             sub new {
56 10     10 1 49177 my $class = shift;
57 10   100     68 my $opt = shift || {};
58 10         23 my %opt;
59              
60 10         36 $opt->{binary} = 1;
61              
62 10         37 for my $attr ( @Attrs, 'encoding', 'coder_class' ) {
63 90 100       290 $opt{ $attr } = delete $opt->{ $attr } if ( exists $opt->{ $attr } );
64             }
65              
66 10   100     119 my $self = $class->SUPER::new( $opt ) || return;
67              
68 9 50 66     1084 if ( my $coder_class = ( $opt{coder_class} || $DefaultCoderClass ) ) {
69 9         43 $self->coder_class( $coder_class );
70             }
71             else {
72 0         0 Carp::croak "Coder class is not specified.";
73             }
74              
75 9         33 for my $attr ( @Attrs, 'encoding' ) {
76 72 100       416 $self->$attr( $opt{ $attr } ) if ( exists $opt{ $attr } );
77             }
78              
79 9         56 $self;
80             }
81              
82              
83             #
84             # Methods
85             #
86              
87             sub combine {
88 21     21 1 22308 my $self = shift;
89 21         49 my @fields = @_;
90              
91 21 100       672 $self->coder->decode_fields_ref( $self->encoding, \@fields ) if ( $self->encoding );
92              
93 21 100       538 unless ( $self->encoding_out ) {
94 6         24 return $self->SUPER::combine( @fields );
95             }
96              
97 15         370 my $ret = $self->encode( $self->encoding_out, \@fields );
98              
99 15 50       78 $self->{_STRING} = \$ret if ( $ret );
100              
101 15         78 return $self->{_STATUS};
102             }
103              
104              
105             sub parse {
106 24     24 1 5934 my $self = shift;
107 24         453 my $ret;
108              
109 24 100       709 if ( $self->encoding_in ) {
110 18         498 $ret = $self->decode( $self->encoding_in, $_[0] );
111             }
112             else {
113 6 50       32 $ret = [ $self->fields ] if $self->SUPER::parse( @_ );
114             }
115              
116 24 50       1141 if ( $ret ) {
117 24 50       712 $self->coder->encode_fields_ref( $self->encoding, $ret ) if ( $self->encoding );
118 24         57 $self->{_FIELDS} = $ret;
119             }
120              
121 24         120 return $self->{_STATUS};
122             }
123              
124              
125             #
126             # IO style
127             #
128              
129             sub print { # to CSV
130 4     4 1 81 my ( $self, $io, $cols ) = @_;
131              
132 4 50       91 $self->coder->decode_fields_ref( $self->encoding, $cols ) if ( $self->encoding );
133 4         8 $self->coder->encode_fields_ref( $self->encoding_out, $cols );
134              
135 4         22 $self->SUPER::print( $io, $cols );
136             }
137              
138              
139             sub getline { # from CSV
140 31     31 1 13832 my ( $self, $io ) = @_;
141 31         90 my $cols = $self->SUPER::getline( $io );
142              
143 31 100       13223 if ( my $binds = $self->{_BOUND_COLUMNS} ) {
144 5         10 for my $val ( @$binds ) {
145 10         21 $$val = $self->coder->decode( $self->encoding_in, $$val );
146 10 50       225 $$val = $self->coder->encode( $self->encoding, $$val ) if ( $self->encoding );
147             }
148 5         14 return $cols;
149             }
150              
151 26 100       64 return unless $cols;
152              
153 21         45 $self->coder->decode_fields_ref( $self->encoding_in, $cols );
154 21 100       504 $self->coder->encode_fields_ref( $self->encoding, $cols ) if ( $self->encoding );
155              
156 21         56 $cols;
157             }
158              
159              
160             #
161             # decode/encode style
162             #
163              
164             sub decode {
165 28     28 1 2832 my ( $self, $enc, $text ) = @_;
166              
167 28 100       88 if ( @_ == 2 ) {
168 5         10 $text = $enc, $enc = '';
169             }
170              
171 28 100       71 $self->coder->upgrade( $text ) unless ( $enc ); # as unicode
172              
173 28 50       73 return unless ( defined $text );
174 28 50       131 return unless ( $self->SUPER::parse( $text ) );
175              
176 28 100       5572 return $enc ? [ map { $self->coder->decode( $enc, $_ ) } $self->fields() ] : [ $self->fields() ];
  37         247  
177             }
178              
179              
180             sub encode {
181 23     23 1 3207 my ( $self, $enc, $array ) = @_;
182              
183 23 100       65 if ( @_ == 2 ) {
184 4         7 $array = $enc, $enc = '';
185             }
186              
187 23 50 33     136 return unless ( defined $array and ref $array eq 'ARRAY' );
188 23 50       91 return unless ( $self->SUPER::combine ( @$array ) );
189              
190 23 100       1526 return $enc ? $self->coder->encode( $enc, $self->string() ) : $self->string();
191             }
192              
193              
194             # Internal
195              
196             sub _load_coder_class {
197 9     9   24 my ( $class, $coder_class ) = @_;
198 9         68 (my $file = "$coder_class.pm") =~ s{::}{/}g;
199              
200 9         20 eval { require $file };
  9         5272  
201              
202 9 50       57 if ( $@ ) {
203 0         0 Carp::croak $@;
204             }
205              
206 9         26 $coder_class;
207             }
208              
209              
210             # Accessors
211              
212             BEGIN {
213 13     13   45 for my $method ( qw( encoding encoding_in encoding_out ) ) {
214 39 100   105 1 8319 eval qq|
  105 100   100 1 334  
  105 100   62 1 364  
  6         10  
  6         16  
  99         391  
  100         10565  
  100         245  
  27         51  
  27         67  
  73         316  
  62         589  
  62         137  
  22         46  
  22         51  
  40         182  
215             sub $method {
216             my ( \$self, \$encoding ) = \@_;
217             if ( \@_ > 1 ) {
218             \$self->{ $method } = \$encoding;
219             return \$self;
220             }
221             else {
222             \$self->{ $method };
223             }
224             }
225             |;
226             }
227             }
228              
229              
230             *encoding_io_in = *encoding_to_parse = *encoding_in;
231             *encoding_io_out = *encoding_to_combine = *encoding_out;
232              
233              
234             sub coder {
235 116     116 1 754 my $self = shift;
236 116   66     1624 $self->{coder} ||= $self->coder_class->new( automatic_UTF8 => $self->automatic_UTF8, @_ );
237             }
238              
239              
240             sub coder_class {
241 18     18 1 62 my ( $self, $coder_class ) = @_;
242              
243 18 100       295 return $self->{coder_class} if ( @_ == 1 );
244              
245 9         42 $self->_load_coder_class( $coder_class );
246 9         41 $self->{coder_class} = $coder_class;
247 9         27 $self;
248             }
249              
250              
251             1;
252             __END__