File Coverage

blib/lib/Data/Recursive/Encode.pm
Criterion Covered Total %
statement 66 66 100.0
branch 14 16 87.5
condition 8 19 42.1
subroutine 17 17 100.0
pod 5 5 100.0
total 110 123 89.4


line stmt bran cond sub pod time code
1             package Data::Recursive::Encode;
2 4     4   144214 use 5.008001;
  4         16  
  4         154  
3 4     4   24 use strict;
  4         7  
  4         451  
4 4     4   22 use warnings FATAL => 'all';
  4         20  
  4         287  
5              
6             our $VERSION = '0.04';
7              
8 4     4   5036 use Encode ();
  4         61625  
  4         103  
9 4     4   40 use Carp ();
  4         93  
  4         90  
10 4     4   26 use Scalar::Util qw(blessed refaddr);
  4         9  
  4         4439  
11              
12             sub _apply {
13 56     56   97 my $code = shift;
14 56         64 my $seen = shift;
15              
16 56         63 my @retval;
17 56         101 for my $arg (@_) {
18 74 100       281 if(my $ref = ref $arg){
19 27         66 my $refaddr = refaddr($arg);
20 27         29 my $proto;
21              
22 27 100 66     171 if(defined($proto = $seen->{$refaddr})){
    100          
    100          
    100          
23             # noop
24             }
25             elsif($ref eq 'ARRAY'){
26 8         24 $proto = $seen->{$refaddr} = [];
27 8         12 @{$proto} = _apply($code, $seen, @{$arg});
  8         20  
  8         18  
28             }
29             elsif($ref eq 'HASH'){
30 6         21 $proto = $seen->{$refaddr} = {};
31 6         12 %{$proto} = _apply($code, $seen, %{$arg});
  6         29  
  6         34  
32             }
33             elsif($ref eq 'REF' or $ref eq 'SCALAR'){
34 4         5 $proto = $seen->{$refaddr} = \do{ my $scalar };
  4         16  
35 4         7 ${$proto} = _apply($code, $seen, ${$arg});
  4         15  
  4         16  
36             }
37             else{ # CODE, GLOB, IO, LVALUE etc.
38 8         20 $proto = $seen->{$refaddr} = $arg;
39             }
40              
41 27         81 push @retval, $proto;
42             }
43             else{
44 47 50       129 push @retval, defined($arg) ? $code->($arg) : $arg;
45             }
46             }
47              
48 56 100       675 return wantarray ? @retval : $retval[0];
49             }
50              
51             sub decode {
52 9     9 1 31902 my ($class, $encoding, $stuff, $check) = @_;
53 9   33     28 $encoding = Encode::find_encoding($encoding)
54             || Carp::croak("$class: unknown encoding '$encoding'");
55 9   50     160 $check ||= 0;
56 9     10   55 _apply(sub { $encoding->decode($_[0], $check) }, {}, $stuff);
  10         102  
57             }
58              
59             sub encode {
60 9     9 1 9232 my ($class, $encoding, $stuff, $check) = @_;
61 9   33     26 $encoding = Encode::find_encoding($encoding)
62             || Carp::croak("$class: unknown encoding '$encoding'");
63 9   50     130 $check ||= 0;
64 9     10   42 _apply(sub { $encoding->encode($_[0], $check) }, {}, $stuff);
  10         56  
65             }
66              
67             sub decode_utf8 {
68 9     9 1 6658 my ($class, $stuff, $check) = @_;
69 9     10   54 _apply(sub { Encode::decode_utf8($_[0], $check) }, {}, $stuff);
  10         37  
70             }
71              
72             sub encode_utf8 {
73 10     10 1 7698 my ($class, $stuff) = @_;
74 10     16   54 _apply(sub { Encode::encode_utf8($_[0]) }, {}, $stuff);
  16         47  
75             }
76              
77             sub from_to {
78 1     1 1 2175 my ($class, $stuff, $from_enc, $to_enc, $check) = @_;
79 1 50       5 @_ >= 4 or Carp::croak("Usage: $class->from_to(OCTET, FROM_ENC, TO_ENC[, CHECK])");
80 1   33     4 $from_enc = Encode::find_encoding($from_enc)
81             || Carp::croak("$class: unknown encoding '$from_enc'");
82 1   33     14 $to_enc = Encode::find_encoding($to_enc)
83             || Carp::croak("$class: unknown encoding '$to_enc'");
84 1     1   148 _apply(sub { Encode::from_to($_[0], $from_enc, $to_enc, $check) }, {}, $stuff);
  1         5  
85 1         7 return $stuff;
86             }
87              
88             1;
89             __END__