File Coverage

blib/lib/Mail/Message/Body/Encode.pm
Criterion Covered Total %
statement 110 154 71.4
branch 61 100 61.0
condition 42 69 60.8
subroutine 17 20 85.0
pod 9 9 100.0
total 239 352 67.9


line stmt bran cond sub pod time code
1             # Copyrights 2001-2021 by [Mark Overmeer ].
2             # For other contributors see ChangeLog.
3             # See the manual pages for details on the licensing terms.
4             # Pod stripped from pm file by OODoc 2.02.
5             # This code is part of distribution Mail-Message. Meta-POD processed with
6             # OODoc into POD and HTML manual-pages. See README.md
7             # Copyright Mark Overmeer. Licensed under the same terms as Perl itself.
8              
9             package Mail::Message::Body;
10 10     10   1431 use vars '$VERSION';
  10         22  
  10         749  
11             $VERSION = '3.011';
12              
13 10     10   67 use base 'Mail::Reporter';
  10         21  
  10         499  
14              
15 10     10   68 use strict;
  10         20  
  10         315  
16 10     10   69 use warnings;
  10         31  
  10         385  
17              
18 10     10   62 use Carp;
  10         19  
  10         712  
19 10     10   67 use MIME::Types ();
  10         21  
  10         249  
20 10     10   69 use File::Basename 'basename';
  10         22  
  10         598  
21 10     10   90 use Encode 'find_encoding';
  10         23  
  10         967  
22              
23 10     10   82 use Mail::Message::Field ();
  10         19  
  10         213  
24 10     10   5474 use Mail::Message::Field::Full ();
  10         38  
  10         537  
25              
26             # http://www.iana.org/assignments/character-sets
27 10     10   115 use Encode::Alias;
  10         24  
  10         15092  
28             define_alias(qr/^unicode-?1-?1-?utf-?([78])$/i => '"UTF-$1"'); # rfc1642
29              
30             my $mime_types;
31              
32              
33             sub encode(@)
34 61     61 1 1608 { my ($self, %args) = @_;
35              
36             # simplify the arguments
37 61         196 my $type_from = $self->type;
38 61   33     349 my $type_to = $args{mime_type} || $type_from->clone->study;
39 61 50       284 $type_to = Mail::Message::Field::Full->new('Content-Type' => $type_to)
40             unless ref $type_to;
41              
42 61   66     311 my $transfer = $args{transfer_encoding} || $self->transferEncoding->clone;
43 61 100       274 $transfer = Mail::Message::Field->new('Content-Transfer-Encoding'
44             => $transfer) unless ref $transfer;
45              
46 61         270 my $trans_was = lc $self->transferEncoding;
47 61         165 my $trans_to = lc $transfer;
48              
49 61         147 my ($char_was, $char_to, $from, $to);
50 61 100       176 if($type_from =~ m!^text/!i)
51 58   50     210 { $char_was = $type_from->attribute('charset') || 'us-ascii';
52 58         196 $char_to = $type_to->attribute('charset');
53              
54 58 100       212 if(my $charset = delete $args{charset})
    50          
55 57 100 66     193 { if(!$char_to || $char_to ne $charset)
56 39         82 { $char_to = $charset;
57 39         128 $type_to->attribute(charset => $char_to);
58             }
59             }
60             elsif(!$char_to)
61 0         0 { $char_to = 'utf8';
62 0         0 $type_to->attribute(charset => $char_to);
63             }
64              
65 58 100       188 if($char_was ne 'PERL')
66 10 50       55 { $from = find_encoding $char_was
67             or $self->log(WARNING => "Charset `$char_was' is not known.");
68             }
69 58 100       748 if($char_to ne 'PERL')
70 31 50       162 { $to = find_encoding $char_to
71             or $self->log(WARNING => "Charset `$char_to' is not known.");
72             }
73              
74 58 50 66     2643 if($trans_to ne 'none' && $char_to eq 'PERL')
75             { # We cannot leave the body into the 'PERL' charset when transfer-
76             # encoding is applied.
77 0         0 $self->log(WARNING => "Transfer-Encoding `$trans_to' requires "
78             . "explicit charset, defaulted to utf8");
79 0         0 $char_to = 'utf8';
80             }
81             }
82              
83              
84             # Any changes to be made?
85 61 100       188 if($trans_was eq $trans_to)
86 23 100 100     151 { return $self if !$from && !$to;
87 6 50 66     47 if($from && $to && $from->name eq $to->name)
      33        
88             { # modify charset into an alias, if requested
89 0 0       0 $self->charset($char_to) if $char_was ne $char_to;
90 0         0 return $self;
91             }
92             }
93              
94 44   33     214 my $bodytype = $args{result_type} || ref $self;
95              
96 44         80 my $decoded;
97 44 100       151 if($trans_was eq 'none')
    50          
98 36         70 { $decoded = $self }
99             elsif(my $decoder = $self->getTransferEncHandler($trans_was))
100 8         42 { $decoded = $decoder->decode($self, result_type => $bodytype) }
101             else
102 0         0 { $self->log(WARNING =>
103             "No decoder defined for transfer encoding $trans_was.");
104 0         0 return $self;
105             }
106              
107 44 50 100     389 my $new_data
    100 100        
    100 66        
108             = $to && $char_was eq 'PERL' ? $to->encode($decoded->string)
109             : $from && $char_to eq 'PERL' ? $from->decode($decoded->string)
110             : $to && $from && $from->name ne $to->name
111             ? $to->encode($from->decode($decoded->string))
112             : undef;
113              
114 44 100       362 my $recoded = $new_data ? $bodytype->new(based_on => $decoded
115             , data => $new_data, mime_type => $type_to, checked => 1) : $decoded;
116              
117 44         89 my $trans;
118 44 100       144 if($trans_to ne 'none')
119 34 50       151 { $trans = $self->getTransferEncHandler($trans_to)
120             or $self->log(WARNING =>
121             "No encoder defined for transfer encoding `$trans_to'.");
122             }
123              
124 44 100       246 my $encoded = defined $trans
125             ? $trans->encode($recoded, result_type => $bodytype)
126             : $recoded;
127              
128 44         165 $encoded;
129             }
130              
131             #------------------------------------------
132              
133              
134             sub check()
135 19     19 1 44 { my $self = shift;
136 19 50       70 return $self if $self->checked;
137 0         0 my $eol = $self->eol;
138              
139 0         0 my $encoding = $self->transferEncoding->body;
140 0 0       0 return $self->eol($eol)
141             if $encoding eq 'none';
142              
143 0         0 my $encoder = $self->getTransferEncHandler($encoding);
144              
145 0 0       0 my $checked
146             = $encoder
147             ? $encoder->check($self)->eol($eol)
148             : $self->eol($eol);
149              
150 0         0 $checked->checked(1);
151 0         0 $checked;
152             }
153              
154             #------------------------------------------
155              
156              
157             sub encoded()
158 51     51 1 110 { my $self = shift;
159              
160 51   66     244 $mime_types ||= MIME::Types->new;
161 51         366 my $mime = $mime_types->type($self->type->body);
162              
163 51   100     2038 my $charset = $self->charset || '';
164 51         194 my $enc_was = $self->transferEncoding;
165 51         105 my $enc = $enc_was;
166 51 50       445 $enc = defined $mime ? $mime->encoding : 'base64'
    100          
167             if $enc eq 'none';
168              
169             # we could (expensively) try to autodetect character-set used,
170             # but everything is a subset of utf-8.
171 51 100 66     236 my $new_charset
    100 66        
172             = (!$mime || $mime !~ m!^text/!i) ? ''
173             : (!$charset || $charset eq 'PERL') ? 'utf-8'
174             : $charset;
175              
176 51 100 100     623 ($enc_was ne 'none' && $charset eq $new_charset)
177             ? $self->check
178             : $self->encode(transfer_encoding => $enc, charset => $new_charset);
179             }
180              
181             #------------------------------------------
182              
183              
184             sub unify($)
185 0     0 1 0 { my ($self, $body) = @_;
186 0 0       0 return $self if $self==$body;
187              
188 0         0 my $mime = $self->type;
189 0         0 my $transfer = $self->transferEncoding;
190              
191 0         0 my $encoded = $body->encode
192             ( mime_type => $mime
193             , transfer_encoding => $transfer
194             );
195              
196             # Encode makes the best of it, but is it good enough?
197              
198 0         0 my $newmime = $encoded->type;
199 0 0       0 return unless $newmime eq $mime;
200 0 0       0 return unless $transfer eq $encoded->transferEncoding;
201 0         0 $encoded;
202             }
203              
204             #------------------------------------------
205              
206              
207             sub isBinary()
208 11     11 1 79 { my $self = shift;
209 11   66     57 $mime_types ||= MIME::Types->new(only_complete => 1);
210 11 50       94 my $type = $self->type or return 1;
211 11 50       49 my $mime = $mime_types->type($type->body) or return 1;
212 11         565 $mime->isBinary;
213             }
214            
215              
216 0     0 1 0 sub isText() { not shift->isBinary }
217              
218              
219             sub dispositionFilename(;$)
220 1     1 1 3 { my $self = shift;
221 1         3 my $raw;
222              
223             my $field;
224 1 50       4 if($field = $self->disposition)
225 1 50       11 { $field = $field->study if $field->can('study');
226 1   33     5 $raw = $field->attribute('filename')
227             || $field->attribute('file')
228             || $field->attribute('name');
229             }
230              
231 1 50 33     8 if(!defined $raw && ($field = $self->type))
232 1 50       16 { $field = $field->study if $field->can('study');
233 1   33     5 $raw = $field->attribute('filename')
234             || $field->attribute('file')
235             || $field->attribute('name');
236             }
237              
238 1         3 my $base;
239 1 50 33     7 if(!defined $raw || !length $raw) {}
    0          
240             elsif(index($raw, '?') >= 0)
241 0         0 { eval 'require Mail::Message::Field::Full';
242 0         0 $base = Mail::Message::Field::Full->decode($raw);
243             }
244             else
245 0         0 { $base = $raw;
246             }
247              
248 1 50       5 return $base
249             unless @_;
250              
251 1         4 my $dir = shift;
252 1         3 my $filename = '';
253 1 50       4 if(defined $base) # RFC6266 section 4.3, very safe
254 0         0 { $filename = basename $base;
255 0         0 for($filename)
256 0         0 { s/\s+/ /g; s/ $//; s/^ //;
  0         0  
  0         0  
257 0         0 s/[^\w .-]//g;
258             }
259             }
260              
261 1 50 33     13 my ($filebase, $ext) = length $filename && $filename =~ m/(.*)\.([^.]+)/
      50        
262             ? ($1, $2) : (part => ($self->mimeType->extensions)[0] || 'raw');
263              
264 1         64 my $fn = File::Spec->catfile($dir, "$filebase.$ext");
265              
266 1         52 for(my $unique = 1; -e $fn; $unique++)
267 0         0 { $fn = File::Spec->catfile($dir, "$filebase-$unique.$ext");
268             }
269              
270 1         8 $fn;
271             }
272              
273             #------------------------------------------
274              
275              
276             my %transfer_encoder_classes =
277             ( base64 => 'Mail::Message::TransferEnc::Base64'
278             , binary => 'Mail::Message::TransferEnc::Binary'
279             , '8bit' => 'Mail::Message::TransferEnc::EightBit'
280             , 'quoted-printable' => 'Mail::Message::TransferEnc::QuotedPrint'
281             , '7bit' => 'Mail::Message::TransferEnc::SevenBit'
282             );
283              
284             my %transfer_encoders; # they are reused.
285              
286             sub getTransferEncHandler($)
287 42     42 1 115 { my ($self, $type) = @_;
288              
289             return $transfer_encoders{$type}
290 42 100       238 if exists $transfer_encoders{$type}; # they are reused.
291              
292 11         37 my $class = $transfer_encoder_classes{$type};
293 11 50       35 return unless $class;
294              
295 11         829 eval "require $class";
296 11 50       65 confess "Cannot load $class: $@\n" if $@;
297              
298 11         136 $transfer_encoders{$type} = $class->new;
299             }
300              
301              
302             sub addTransferEncHandler($$)
303 0     0 1   { my ($this, $name, $what) = @_;
304              
305 0           my $class;
306 0 0         if(ref $what)
307 0           { $transfer_encoders{$name} = $what;
308 0           $class = ref $what;
309             }
310             else
311 0           { delete $transfer_encoders{$name};
312 0           $class = $what;
313             }
314              
315 0           $transfer_encoder_classes{$name} = $class;
316 0           $this;
317             }
318              
319             1;