File Coverage

blib/lib/Email/MIME/Encode.pm
Criterion Covered Total %
statement 96 96 100.0
branch 34 46 73.9
condition 10 12 83.3
subroutine 17 17 100.0
pod 0 4 0.0
total 157 175 89.7


line stmt bran cond sub pod time code
1 20     20   80486 use strict;
  20         62  
  20         717  
2 20     20   112 use warnings;
  20         41  
  20         893  
3             package Email::MIME::Encode 1.951;
4             # ABSTRACT: a private helper for MIME header encoding
5              
6 20     20   127 use Carp ();
  20         39  
  20         263  
7 20     20   721 use Encode ();
  20         10712  
  20         337  
8 20     20   8174 use Email::MIME::Header;
  20         57  
  20         730  
9 20     20   8737 use MIME::Base64();
  20         13120  
  20         513  
10 20     20   133 use Module::Runtime ();
  20         41  
  20         355  
11 20     20   106 use Scalar::Util;
  20         39  
  20         5256  
12              
13             our @CARP_NOT;
14              
15             my %no_mime_headers = map { $_ => undef } qw(date message-id in-reply-to references downgraded-message-id downgraded-in-reply-to downgraded-references);
16              
17             sub maybe_mime_encode_header {
18 44     44 0 207 my ($header, $val, $charset) = @_;
19              
20 44         89 $header = lc $header;
21              
22 44         99 my $header_name_length = length($header) + length(": ");
23              
24 44 100 100     190 if (Scalar::Util::blessed($val) && $val->can("as_mime_string")) {
25 2         12 return $val->as_mime_string({
26             charset => $charset,
27             header_name_length => $header_name_length,
28             });
29             }
30              
31             return _object_encode($val, $charset, $header_name_length, $Email::MIME::Header::header_to_class_map{$header})
32 42 100       138 if exists $Email::MIME::Header::header_to_class_map{$header};
33              
34 20         34 my $min_wrap_length = 78 - $header_name_length + 1;
35              
36 20 100 66     35 return $val
37             unless _needs_mime_encode($val) || $val =~ /[^\s]{$min_wrap_length,}/;
38              
39             return $val
40 11 50       33 if exists $no_mime_headers{$header};
41              
42 11         24 return mime_encode($val, $charset, $header_name_length);
43             }
44              
45             sub _needs_mime_encode {
46 100     100   166 my ($val) = @_;
47 100   100 1   1177 return defined $val && $val =~ /(?:\P{ASCII}|=\?|[^\s]{79,}|^\s+|\s+$)/s;
  1         19  
  1         10  
  1         19  
48             }
49              
50             sub _needs_mime_encode_addr {
51 80     80   436 my ($val) = @_;
52 80   66     138 return _needs_mime_encode($val) || ( defined $val && $val =~ /[:;,]/ );
53             }
54              
55             sub _object_encode {
56 22     22   54 my ($val, $charset, $header_name_length, $class) = @_;
57              
58 22         68 local @CARP_NOT = qw(Email::MIME Email::MIME::Header);
59              
60             {
61 22         35 local $@;
  22         34  
62 22 50       39 Carp::croak("Cannot load package '$class': $@") unless eval { Module::Runtime::require_module($class) };
  22         64  
63             }
64              
65 22 50       799 Carp::croak("Class '$class' does not have method 'from_string'") unless $class->can('from_string');
66              
67 22 100       114 my $object = $class->from_string(ref $val eq 'ARRAY' ? @{$val} : $val);
  2         9  
68              
69 22 50       98 Carp::croak("Object from class '$class' does not have method 'as_mime_string'") unless $object->can('as_mime_string');
70              
71 22         101 return $object->as_mime_string({
72             charset => $charset,
73             header_name_length => $header_name_length,
74             });
75             }
76              
77             # XXX this is copied directly out of Courriel::Header
78             # eventually, this should be extracted out into something that could be shared
79             sub mime_encode {
80 36     36 0 192 my ($text, $charset, $header_name_length) = @_;
81              
82 36 100       85 $header_name_length = 0 unless defined $header_name_length;
83 36 100       69 $charset = 'UTF-8' unless defined $charset;
84              
85 36         106 my $enc_obj = Encode::find_encoding($charset);
86              
87 36         1519 my $head = '=?' . $enc_obj->mime_name() . '?B?';
88 36         2582 my $tail = '?=';
89              
90 36         63 my $mime_length = length($head) + length($tail);
91              
92             # This code is copied from Mail::Message::Field::Full in the Mail-Box
93             # distro.
94 36         123 my $real_length = int( ( 75 - $mime_length ) / 4 ) * 3;
95 36         65 my $first_length = int( ( 75 - $header_name_length - $mime_length ) / 4 ) * 3;
96              
97 36         49 my @result;
98 36         52 my $chunk = q{};
99 36         44 my $first_processed = 0;
100 36         188 while ( length( my $chr = substr( $text, 0, 1, '' ) ) ) {
101 832         1942 my $chr = $enc_obj->encode( $chr, 0 );
102              
103 832 100       1848 if ( length($chunk) + length($chr) > ( $first_processed ? $real_length : $first_length ) ) {
    100          
104 8 50       20 if ( length($chunk) > 0 ) {
105 8         34 push @result, $head . MIME::Base64::encode_base64( $chunk, q{} ) . $tail;
106 8         14 $chunk = q{};
107             }
108 8 50       51 $first_processed = 1
109             unless $first_processed;
110             }
111              
112 832         2537 $chunk .= $chr;
113             }
114              
115 36 50       192 push @result, $head . MIME::Base64::encode_base64( $chunk, q{} ) . $tail
116             if length $chunk;
117              
118 36         231 return join q{ }, @result;
119             }
120              
121             sub maybe_mime_decode_header {
122 37     37 0 71 my ($header, $val) = @_;
123              
124 37         74 $header = lc $header;
125              
126             return _object_decode($val, $Email::MIME::Header::header_to_class_map{$header})
127 37 100       113 if exists $Email::MIME::Header::header_to_class_map{$header};
128              
129             return $val
130 16 100       35 if exists $no_mime_headers{$header};
131              
132 15 100       39 return $val
133             unless $val =~ /=\?/;
134              
135 14         26 return mime_decode($val);
136             }
137              
138             sub _object_decode {
139 21     21   84 my ($string, $class) = @_;
140              
141 21         61 local @CARP_NOT = qw(Email::MIME Email::MIME::Header);
142              
143             {
144 21         64 local $@;
  21         31  
145 21 50       38 Carp::croak("Cannot load package '$class': $@") unless eval { Module::Runtime::require_module($class) };
  21         68  
146             }
147              
148 21 50       821 Carp::croak("Class '$class' does not have method 'from_mime_string'") unless $class->can('from_mime_string');
149              
150 21         68 my $object = $class->from_mime_string($string);
151              
152 21 50       112 Carp::croak("Object from class '$class' does not have method 'as_string'") unless $object->can('as_string');
153              
154 21         61 return $object->as_string();
155             }
156              
157             sub mime_decode {
158 64     64 0 311 my ($text) = @_;
159 64 50       129 return undef unless defined $text;
160              
161             # The eval is to cope with unknown encodings, like Latin-62, or other
162             # nonsense that gets put in there by spammers and weirdos
163             # -- rjbs, 2014-12-04
164 64         90 local $@;
165 64         109 my $result = eval { Encode::decode("MIME-Header", $text) };
  64         167  
166 64 50       27116 return defined $result ? $result : $text;
167             }
168              
169             1;
170              
171             __END__