1# Copyrights 2001-2021 by [Mark Overmeer <markov@cpan.org>].
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
9package Mail::Message::Body;
10use vars '$VERSION';
11$VERSION = '3.011';
12
13use base 'Mail::Reporter';
14
15use strict;
16use warnings;
17
18use Carp;
19use MIME::Types    ();
20use File::Basename 'basename';
21use Encode         'find_encoding';
22
23use Mail::Message::Field        ();
24use Mail::Message::Field::Full  ();
25
26# http://www.iana.org/assignments/character-sets
27use Encode::Alias;
28define_alias(qr/^unicode-?1-?1-?utf-?([78])$/i => '"UTF-$1"');  # rfc1642
29
30my $mime_types;
31
32
33sub encode(@)
34{   my ($self, %args) = @_;
35
36    # simplify the arguments
37    my $type_from = $self->type;
38    my $type_to   = $args{mime_type} || $type_from->clone->study;
39    $type_to = Mail::Message::Field::Full->new('Content-Type' => $type_to)
40        unless ref $type_to;
41
42    my $transfer = $args{transfer_encoding} || $self->transferEncoding->clone;
43    $transfer    = Mail::Message::Field->new('Content-Transfer-Encoding'
44        => $transfer) unless ref $transfer;
45
46    my $trans_was = lc $self->transferEncoding;
47    my $trans_to  = lc $transfer;
48
49    my ($char_was, $char_to, $from, $to);
50    if($type_from =~ m!^text/!i)
51    {   $char_was = $type_from->attribute('charset') || 'us-ascii';
52        $char_to  = $type_to->attribute('charset');
53
54        if(my $charset = delete $args{charset})
55        {   if(!$char_to || $char_to ne $charset)
56            {   $char_to = $charset;
57                $type_to->attribute(charset => $char_to);
58            }
59        }
60        elsif(!$char_to)
61        {   $char_to = 'utf8';
62            $type_to->attribute(charset => $char_to);
63        }
64
65        if($char_was ne 'PERL')
66        {   $from = find_encoding $char_was
67                or $self->log(WARNING => "Charset `$char_was' is not known.");
68        }
69        if($char_to ne 'PERL')
70        {   $to = find_encoding $char_to
71                or $self->log(WARNING => "Charset `$char_to' is not known.");
72        }
73
74        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            $self->log(WARNING => "Transfer-Encoding `$trans_to' requires "
78              . "explicit charset, defaulted to utf8");
79            $char_to = 'utf8';
80        }
81    }
82
83
84    # Any changes to be made?
85    if($trans_was eq $trans_to)
86    {   return $self if !$from && !$to;
87        if($from && $to && $from->name eq $to->name)
88        {   # modify charset into an alias, if requested
89            $self->charset($char_to) if $char_was ne $char_to;
90            return $self;
91        }
92    }
93
94    my $bodytype  = $args{result_type} || ref $self;
95
96    my $decoded;
97    if($trans_was eq 'none')
98    {   $decoded = $self }
99    elsif(my $decoder = $self->getTransferEncHandler($trans_was))
100    {   $decoded = $decoder->decode($self, result_type => $bodytype) }
101    else
102    {   $self->log(WARNING =>
103           "No decoder defined for transfer encoding $trans_was.");
104        return $self;
105    }
106
107    my $new_data
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    my $recoded = $new_data ? $bodytype->new(based_on => $decoded
115      , data => $new_data, mime_type => $type_to, checked => 1) : $decoded;
116
117    my $trans;
118    if($trans_to ne 'none')
119    {   $trans = $self->getTransferEncHandler($trans_to)
120           or $self->log(WARNING =>
121               "No encoder defined for transfer encoding `$trans_to'.");
122    }
123
124    my $encoded = defined $trans
125      ? $trans->encode($recoded, result_type => $bodytype)
126      : $recoded;
127
128    $encoded;
129}
130
131#------------------------------------------
132
133
134sub check()
135{   my $self     = shift;
136    return $self if $self->checked;
137    my $eol      = $self->eol;
138
139    my $encoding = $self->transferEncoding->body;
140    return $self->eol($eol)
141       if $encoding eq 'none';
142
143    my $encoder  = $self->getTransferEncHandler($encoding);
144
145    my $checked
146      = $encoder
147      ? $encoder->check($self)->eol($eol)
148      : $self->eol($eol);
149
150    $checked->checked(1);
151    $checked;
152}
153
154#------------------------------------------
155
156
157sub encoded()
158{   my $self = shift;
159
160    $mime_types ||= MIME::Types->new;
161    my $mime    = $mime_types->type($self->type->body);
162
163    my $charset = $self->charset || '';
164    my $enc_was = $self->transferEncoding;
165    my $enc     = $enc_was;
166    $enc        = defined $mime ? $mime->encoding : 'base64'
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    my $new_charset
172       = (!$mime || $mime !~ m!^text/!i)   ? ''
173       : (!$charset || $charset eq 'PERL') ? 'utf-8'
174       :                                     $charset;
175
176      ($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
184sub unify($)
185{   my ($self, $body) = @_;
186    return $self if $self==$body;
187
188    my $mime     = $self->type;
189    my $transfer = $self->transferEncoding;
190
191    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    my $newmime     = $encoded->type;
199    return unless $newmime  eq $mime;
200    return unless $transfer eq $encoded->transferEncoding;
201    $encoded;
202}
203
204#------------------------------------------
205
206
207sub isBinary()
208{   my $self = shift;
209    $mime_types ||= MIME::Types->new(only_complete => 1);
210    my $type = $self->type                    or return 1;
211    my $mime = $mime_types->type($type->body) or return 1;
212    $mime->isBinary;
213}
214
215
216sub isText() { not shift->isBinary }
217
218
219sub dispositionFilename(;$)
220{   my $self = shift;
221    my $raw;
222
223    my $field;
224    if($field = $self->disposition)
225    {   $field = $field->study if $field->can('study');
226        $raw   = $field->attribute('filename')
227              || $field->attribute('file')
228              || $field->attribute('name');
229    }
230
231    if(!defined $raw && ($field = $self->type))
232    {   $field = $field->study if $field->can('study');
233        $raw   = $field->attribute('filename')
234              || $field->attribute('file')
235              || $field->attribute('name');
236    }
237
238    my $base;
239    if(!defined $raw || !length $raw) {}
240    elsif(index($raw, '?') >= 0)
241    {   eval 'require Mail::Message::Field::Full';
242        $base = Mail::Message::Field::Full->decode($raw);
243    }
244    else
245    {   $base = $raw;
246    }
247
248    return $base
249        unless @_;
250
251    my $dir      = shift;
252    my $filename = '';
253    if(defined $base)   # RFC6266 section 4.3, very safe
254    {   $filename = basename $base;
255        for($filename)
256        {   s/\s+/ /g;  s/ $//; s/^ //;
257            s/[^\w .-]//g;
258        }
259    }
260
261	my ($filebase, $ext) = length $filename && $filename =~ m/(.*)\.([^.]+)/
262      ? ($1, $2) : (part => ($self->mimeType->extensions)[0] || 'raw');
263
264    my $fn = File::Spec->catfile($dir, "$filebase.$ext");
265
266    for(my $unique = 1; -e $fn; $unique++)
267    {   $fn = File::Spec->catfile($dir, "$filebase-$unique.$ext");
268    }
269
270	$fn;
271}
272
273#------------------------------------------
274
275
276my %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
284my %transfer_encoders;   # they are reused.
285
286sub getTransferEncHandler($)
287{   my ($self, $type) = @_;
288
289    return $transfer_encoders{$type}
290        if exists $transfer_encoders{$type};   # they are reused.
291
292    my $class = $transfer_encoder_classes{$type};
293    return unless $class;
294
295    eval "require $class";
296    confess "Cannot load $class: $@\n" if $@;
297
298    $transfer_encoders{$type} = $class->new;
299}
300
301
302sub addTransferEncHandler($$)
303{   my ($this, $name, $what) = @_;
304
305    my $class;
306    if(ref $what)
307    {   $transfer_encoders{$name} = $what;
308        $class = ref $what;
309    }
310    else
311    {   delete $transfer_encoders{$name};
312        $class = $what;
313    }
314
315    $transfer_encoder_classes{$name} = $class;
316    $this;
317}
318
3191;
320