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