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::Multipart; 10use vars '$VERSION'; 11$VERSION = '3.011'; 12 13use base 'Mail::Message::Body'; 14 15use strict; 16use warnings; 17 18use Mail::Message::Body::Lines; 19use Mail::Message::Part; 20 21use Mail::Box::FastScalar; 22use Carp; 23 24 25sub init($) 26{ my ($self, $args) = @_; 27 my $based = $args->{based_on}; 28 $args->{mime_type} ||= defined $based ? $based->type : 'multipart/mixed'; 29 30 $self->SUPER::init($args); 31 32 my @parts; 33 if($args->{parts}) 34 { foreach my $raw (@{$args->{parts}}) 35 { next unless defined $raw; 36 my $cooked = Mail::Message::Part->coerce($raw, $self); 37 38 $self->log(ERROR => 'Data not convertible to a message (type is ' 39 , ref $raw,")\n"), next unless defined $cooked; 40 41 push @parts, $cooked; 42 } 43 } 44 45 my $preamble = $args->{preamble}; 46 $preamble = Mail::Message::Body->new(data => $preamble) 47 if defined $preamble && ! ref $preamble; 48 49 my $epilogue = $args->{epilogue}; 50 $epilogue = Mail::Message::Body->new(data => $epilogue) 51 if defined $epilogue && ! ref $epilogue; 52 53 if($based) 54 { $self->boundary($args->{boundary} || $based->boundary); 55 $self->{MMBM_preamble} 56 = defined $preamble ? $preamble : $based->preamble; 57 58 $self->{MMBM_parts} 59 = @parts ? \@parts 60 : !$args->{parts} && $based->isMultipart 61 ? [ $based->parts('ACTIVE') ] 62 : []; 63 64 $self->{MMBM_epilogue} 65 = defined $epilogue ? $epilogue : $based->epilogue; 66 } 67 else 68 { $self->boundary($args->{boundary} ||$self->type->attribute('boundary')); 69 $self->{MMBM_preamble} = $preamble; 70 $self->{MMBM_parts} = \@parts; 71 $self->{MMBM_epilogue} = $epilogue; 72 } 73 74 $self; 75} 76 77sub isMultipart() {1} 78 79# A multipart body is never binary itself. The parts may be. 80sub isBinary() {0} 81 82sub clone() 83{ my $self = shift; 84 my $preamble = $self->preamble; 85 my $epilogue = $self->epilogue; 86 87 my $body = ref($self)->new 88 ( $self->logSettings 89 , based_on => $self 90 , preamble => ($preamble ? $preamble->clone : undef) 91 , epilogue => ($epilogue ? $epilogue->clone : undef) 92 , parts => [ map {$_->clone} $self->parts('ACTIVE') ] 93 ); 94 95} 96 97sub nrLines() 98{ my $self = shift; 99 my $nr = 1; # trailing part-sep 100 101 if(my $preamble = $self->preamble) 102 { $nr += $preamble->nrLines; 103 $nr++ if $preamble->endsOnNewline; 104 } 105 106 foreach my $part ($self->parts('ACTIVE')) 107 { $nr += 1 + $part->nrLines; 108 $nr++ if $part->body->endsOnNewline; 109 } 110 111 if(my $epilogue = $self->epilogue) 112 { $nr += $epilogue->nrLines; 113 } 114 115 $nr; 116} 117 118sub size() 119{ my $self = shift; 120 my $bbytes = length($self->boundary) +4; # \n--$b\n 121 122 my $bytes = $bbytes +2; # last boundary, \n--$b--\n 123 if(my $preamble = $self->preamble) 124 { $bytes += $preamble->size } 125 else { $bytes -= 1 } # no leading \n 126 127 $bytes += $bbytes + $_->size foreach $self->parts('ACTIVE'); 128 if(my $epilogue = $self->epilogue) 129 { $bytes += $epilogue->size; 130 } 131 $bytes; 132} 133 134sub string() { join '', shift->lines } 135 136sub lines() 137{ my $self = shift; 138 139 my $boundary = $self->boundary; 140 my @lines; 141 142 my $preamble = $self->preamble; 143 push @lines, $preamble->lines if $preamble; 144 145 foreach my $part ($self->parts('ACTIVE')) 146 { # boundaries start with \n 147 if(!@lines) { ; } 148 elsif($lines[-1] =~ m/\n$/) { push @lines, "\n" } 149 else { $lines[-1] .= "\n" } 150 push @lines, "--$boundary\n", $part->lines; 151 } 152 153 if(!@lines) { ; } 154 elsif($lines[-1] =~ m/\n$/) { push @lines, "\n" } 155 else { $lines[-1] .= "\n" } 156 push @lines, "--$boundary--"; 157 158 if(my $epilogue = $self->epilogue) 159 { $lines[-1] .= "\n"; 160 push @lines, $epilogue->lines; 161 } 162 163 wantarray ? @lines : \@lines; 164} 165 166sub file() # It may be possible to speed-improve the next 167{ my $self = shift; # code, which first produces a full print of 168 my $text; # the message in memory... 169 my $dump = Mail::Box::FastScalar->new(\$text); 170 $self->print($dump); 171 $dump->seek(0,0); 172 $dump; 173} 174 175sub print(;$) 176{ my $self = shift; 177 my $out = shift || select; 178 179 my $boundary = $self->boundary; 180 my $count = 0; 181 if(my $preamble = $self->preamble) 182 { $preamble->print($out); 183 $count++; 184 } 185 186 if(ref $out eq 'GLOB') 187 { foreach my $part ($self->parts('ACTIVE')) 188 { print $out "\n" if $count++; 189 print $out "--$boundary\n"; 190 $part->print($out); 191 } 192 print $out "\n" if $count++; 193 print $out "--$boundary--"; 194 } 195 else 196 { foreach my $part ($self->parts('ACTIVE')) 197 { $out->print("\n") if $count++; 198 $out->print("--$boundary\n"); 199 $part->print($out); 200 } 201 $out->print("\n") if $count++; 202 $out->print("--$boundary--"); 203 } 204 205 if(my $epilogue = $self->epilogue) 206 { $out->print("\n"); 207 $epilogue->print($out); 208 } 209 210 $self; 211} 212 213 214sub foreachLine($) 215{ my ($self, $code) = @_; 216 $self->log(ERROR => "You cannot use foreachLine on a multipart"); 217 confess; 218} 219 220sub check() 221{ my $self = shift; 222 $self->foreachComponent( sub {$_[1]->check} ); 223} 224 225sub encode(@) 226{ my ($self, %args) = @_; 227 $self->foreachComponent( sub {$_[1]->encode(%args)} ); 228} 229 230sub encoded() 231{ my $self = shift; 232 $self->foreachComponent( sub {$_[1]->encoded} ); 233} 234 235sub read($$$$) 236{ my ($self, $parser, $head, $bodytype) = @_; 237 238 my $boundary = $self->boundary; 239 240 $parser->pushSeparator("--$boundary"); 241 my @msgopts = $self->logSettings; 242 243 my $te; 244 $te = lc $1 245 if +($head->get('Content-Transfer-Encoding') || '') =~ m/(\w+)/; 246 247 my @sloppyopts = 248 ( mime_type => 'text/plain' 249 , transfer_encoding => $te 250 ); 251 252 # Get preamble. 253 my $headtype = ref $head; 254 255 my $begin = $parser->filePosition; 256 my $preamble = Mail::Message::Body::Lines->new(@msgopts, @sloppyopts) 257 ->read($parser, $head); 258 259 $preamble->nrLines 260 or undef $preamble; 261 262 $self->{MMBM_preamble} = $preamble 263 if defined $preamble; 264 265 # Get the parts. 266 267 my @parts; 268 while(my $sep = $parser->readSeparator) 269 { last if $sep eq "--$boundary--\n"; 270 271 my $part = Mail::Message::Part->new 272 ( @msgopts 273 , container => $self 274 ); 275 276 last unless $part->readFromParser($parser, $bodytype); 277 push @parts, $part 278 if $part->head->names || $part->body->size; 279 } 280 $self->{MMBM_parts} = \@parts; 281 282 # Get epilogue 283 284 $parser->popSeparator; 285 my $epilogue = Mail::Message::Body::Lines->new(@msgopts, @sloppyopts) 286 ->read($parser, $head); 287 288 my $end = defined $epilogue ? ($epilogue->fileLocation)[1] 289 : @parts ? ($parts[-1]->body->fileLocation)[1] 290 : defined $preamble ? ($preamble->fileLocation)[1] 291 : $begin; 292 $self->fileLocation($begin, $end); 293 294 $epilogue->nrLines 295 or undef $epilogue; 296 297 $self->{MMBM_epilogue} = $epilogue 298 if defined $epilogue; 299 300 $self; 301} 302 303#------------------------------------------ 304 305 306sub foreachComponent($) 307{ my ($self, $code) = @_; 308 my $changes = 0; 309 310 my $new_preamble; 311 if(my $preamble = $self->preamble) 312 { $new_preamble = $code->($self, $preamble); 313 $changes++ unless $preamble == $new_preamble; 314 } 315 316 my $new_epilogue; 317 if(my $epilogue = $self->epilogue) 318 { $new_epilogue = $code->($self, $epilogue); 319 $changes++ unless $epilogue == $new_epilogue; 320 } 321 322 my @new_bodies; 323 foreach my $part ($self->parts('ACTIVE')) 324 { my $part_body = $part->body; 325 my $new_body = $code->($self, $part_body); 326 327 $changes++ if $new_body != $part_body; 328 push @new_bodies, [$part, $new_body]; 329 } 330 331 return $self unless $changes; 332 333 my @new_parts; 334 foreach (@new_bodies) 335 { my ($part, $body) = @$_; 336 my $new_part = Mail::Message::Part->new 337 ( head => $part->head->clone, 338 container => undef 339 ); 340 $new_part->body($body); 341 push @new_parts, $new_part; 342 } 343 344 my $constructed = (ref $self)->new 345 ( preamble => $new_preamble 346 , parts => \@new_parts 347 , epilogue => $new_epilogue 348 , based_on => $self 349 ); 350 351 $_->container($constructed) 352 foreach @new_parts; 353 354 $constructed; 355} 356 357 358sub attach(@) 359{ my $self = shift; 360 my $new = ref($self)->new 361 ( based_on => $self 362 , parts => [$self->parts, @_] 363 ); 364} 365 366 367sub stripSignature(@) 368{ my $self = shift; 369 370 my @allparts = $self->parts; 371 my @parts = grep {! $_->body->mimeType->isSignature} @allparts; 372 373 @allparts==@parts ? $self 374 : (ref $self)->new(based_on => $self, parts => \@parts); 375} 376 377#------------------------------------------ 378 379 380sub preamble() {shift->{MMBM_preamble}} 381 382 383sub epilogue() {shift->{MMBM_epilogue}} 384 385 386sub parts(;$) 387{ my $self = shift; 388 return @{$self->{MMBM_parts}} unless @_; 389 390 my $what = shift; 391 my @parts = @{$self->{MMBM_parts}}; 392 393 $what eq 'RECURSE' ? (map {$_->parts('RECURSE')} @parts) 394 : $what eq 'ALL' ? @parts 395 : $what eq 'DELETED' ? (grep {$_->isDeleted} @parts) 396 : $what eq 'ACTIVE' ? (grep {not $_->isDeleted} @parts) 397 : ref $what eq 'CODE'? (grep {$what->($_)} @parts) 398 : ($self->log(ERROR => "Unknown criterium $what to select parts."), return ()); 399} 400 401 402sub part($) { shift->{MMBM_parts}[shift] } 403 404sub partNumberOf($) 405{ my ($self, $part) = @_; 406 my @parts = $self->parts('ACTIVE'); 407 my $msg = $self->message; 408 unless($msg) 409 { $self->log(ERROR => 'multipart is not connected'); 410 return 'ERROR'; 411 } 412 my $base = $msg->isa('Mail::Message::Part') ? $msg->partNumber.'.' : ''; 413 foreach my $partnr (0..@parts) 414 { return $base.($partnr+1) 415 if $parts[$partnr] == $part; 416 } 417 $self->log(ERROR => 'multipart is not found or not active'); 418 'ERROR'; 419} 420 421 422sub boundary(;$) 423{ my $self = shift; 424 my $mime = $self->type; 425 426 unless(@_) 427 { my $boundary = $mime->attribute('boundary'); 428 return $boundary if defined $boundary; 429 } 430 431 my $boundary = @_ && defined $_[0] ? (shift) : "boundary-".int rand(1000000); 432 $self->type->attribute(boundary => $boundary); 433} 434 435sub endsOnNewline() { 1 } 436 437sub toplevel() { my $msg = shift->message; $msg ? $msg->toplevel : undef} 438 439#------------------------------------------- 440 441 4421; 443