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; 10use vars '$VERSION'; 11$VERSION = '3.011'; 12 13use base 'Mail::Reporter'; 14 15use strict; 16use warnings; 17 18use Mail::Message::Part (); 19use Mail::Message::Head::Complete (); 20use Mail::Message::Construct (); 21 22use Mail::Message::Body::Lines (); 23use Mail::Message::Body::Multipart (); 24use Mail::Message::Body::Nested (); 25 26use Carp; 27use Scalar::Util qw(weaken blessed); 28 29BEGIN { 30 unless($ENV{HARNESS_ACTIVE}) { # no tests during upgrade 31 # v3 splits Mail::Box in a few distributions 32 eval { require Mail::Box }; 33 my $v = $Mail::Box::VERSION || 3; 34 $v >= 3 or die "You need to upgrade the Mail::Box module"; 35 } 36} 37 38 39our $crlf_platform = $^O =~ m/win32/i; 40 41#------------------------------------------ 42 43 44sub init($) 45{ my ($self, $args) = @_; 46 $self->SUPER::init($args); 47 48 # Field initializations also in coerce() 49 $self->{MM_modified} = $args->{modified} || 0; 50 $self->{MM_trusted} = $args->{trusted} || 0; 51 52 # Set the header 53 54 my $head; 55 if(defined($head = $args->{head})) { $self->head($head) } 56 elsif(my $msgid = $args->{messageId} || $args->{messageID}) 57 { $self->takeMessageId($msgid); 58 } 59 60 # Set the body 61 if(my $body = $args->{body}) 62 { $self->{MM_body} = $body; 63 $body->message($self); 64 } 65 66 $self->{MM_body_type} = $args->{body_type} 67 if defined $args->{body_type}; 68 69 $self->{MM_head_type} = $args->{head_type} 70 if defined $args->{head_type}; 71 72 $self->{MM_field_type} = $args->{field_type} 73 if defined $args->{field_type}; 74 75 my $labels = $args->{labels} || []; 76 my @labels = ref $labels eq 'ARRAY' ? @$labels : %$labels; 77 push @labels, deleted => $args->{deleted} if exists $args->{deleted}; 78 $self->{MM_labels} = { @labels }; 79 80 $self; 81} 82 83 84sub clone(@) 85{ my ($self, %args) = @_; 86 87 # First clone body, which may trigger head load as well. If head is 88 # triggered first, then it may be decided to be lazy on the body at 89 # moment. And then the body would be triggered. 90 91 my ($head, $body) = ($self->head, $self->body); 92 $head = $head->clone 93 unless $args{shallow} || $args{shallow_head}; 94 95 $body = $body->clone 96 unless $args{shallow} || $args{shallow_body}; 97 98 my $clone = Mail::Message->new 99 ( head => $head 100 , body => $body 101 , $self->logSettings 102 ); 103 104 my $labels = $self->labels; 105 my %labels = %$labels; 106 delete $labels{deleted}; 107 108 $clone->{MM_labels} = \%labels; 109 110 $clone->{MM_cloned} = $self; 111 weaken($clone->{MM_cloned}); 112 113 $clone; 114} 115 116#------------------------------------------ 117 118 119sub messageId() { $_[0]->{MM_message_id} || $_[0]->takeMessageId} 120sub messageID() {shift->messageId} # compatibility 121 122 123sub container() { undef } # overridden by Mail::Message::Part 124 125 126sub isPart() { 0 } # overridden by Mail::Message::Part 127 128 129sub partNumber() 130{ my $self = shift; 131 my $cont = $self->container; 132 $cont ? $cont->partNumber : undef; 133} 134 135 136sub toplevel() { shift } # overridden by Mail::Message::Part 137 138 139sub isDummy() { 0 } 140 141 142sub print(;$) 143{ my $self = shift; 144 my $out = shift || select; 145 146 $self->head->print($out); 147 my $body = $self->body; 148 $body->print($out) if $body; 149 $self; 150} 151 152 153sub write(;$) 154{ my $self = shift; 155 my $out = shift || select; 156 157 $self->head->print($out); 158 $self->body->print($out); 159 $self; 160} 161 162 163my $default_mailer; 164 165sub send(@) 166{ my $self = shift; 167 168 # Loosely coupled module 169 require Mail::Transport::Send; 170 171 my $mailer; 172 $default_mailer = $mailer = shift 173 if ref $_[0] && $_[0]->isa('Mail::Transport::Send'); 174 175 my %args = @_; 176 if( ! $args{via} && defined $default_mailer ) 177 { $mailer = $default_mailer; 178 } 179 else 180 { my $via = delete $args{via} || 'sendmail'; 181 $default_mailer = $mailer = Mail::Transport->new(via => $via, %args); 182 } 183 184 $mailer->send($self, %args); 185} 186 187 188sub size() 189{ my $self = shift; 190 $self->head->size + $self->body->size; 191} 192 193#------------------------------------------ 194 195 196sub head(;$) 197{ my $self = shift; 198 return $self->{MM_head} unless @_; 199 200 my $head = shift; 201 unless(defined $head) 202 { delete $self->{MM_head}; 203 return undef; 204 } 205 206 $self->log(INTERNAL => "wrong type of head ($head) for message $self") 207 unless ref $head && $head->isa('Mail::Message::Head'); 208 209 $head->message($self); 210 211 if(my $old = $self->{MM_head}) 212 { $self->{MM_modified}++ unless $old->isDelayed; 213 } 214 215 $self->{MM_head} = $head; 216 217 $self->takeMessageId unless $head->isDelayed; 218 219 $head; 220} 221 222 223sub get($) 224{ my $self = shift; 225 my $field = $self->head->get(shift) || return undef; 226 $field->body; 227} 228 229 230sub study($) 231{ my $head = shift->head or return; 232 scalar $head->study(@_); # return only last 233} 234 235 236sub from() 237{ my @from = shift->head->get('From') or return (); 238 map $_->addresses, @from; 239} 240 241 242sub sender() 243{ my $self = shift; 244 my $sender = $self->head->get('Sender') || $self->head->get('From') 245 || return (); 246 247 ($sender->addresses)[0]; # first specified address 248} 249 250 251sub to() { map $_->addresses, shift->head->get('To') } 252 253 254sub cc() { map $_->addresses, shift->head->get('Cc') } 255 256 257sub bcc() { map $_->addresses, shift->head->get('Bcc') } 258 259 260sub destinations() 261{ my $self = shift; 262 my %to = map +(lc($_->address) => $_), $self->to, $self->cc, $self->bcc; 263 values %to; 264} 265 266 267sub subject() 268{ my $subject = shift->get('subject'); 269 defined $subject ? $subject : ''; 270} 271 272 273sub guessTimestamp() {shift->head->guessTimestamp} 274 275 276sub timestamp() 277{ my $head = shift->head; 278 $head->recvstamp || $head->timestamp; 279} 280 281 282sub nrLines() 283{ my $self = shift; 284 $self->head->nrLines + $self->body->nrLines; 285} 286 287#------------------------------------------- 288 289 290sub body(;$@) 291{ my $self = shift; 292 return $self->{MM_body} unless @_; 293 294 my $head = $self->head; 295 $head->removeContentInfo if defined $head; 296 297 my ($rawbody, %args) = @_; 298 unless(defined $rawbody) 299 { # Disconnect body from message. 300 my $body = delete $self->{MM_body}; 301 $body->message(undef) if defined $body; 302 return $body; 303 } 304 305 ref $rawbody && $rawbody->isa('Mail::Message::Body') 306 or $self->log(INTERNAL => "wrong type of body for message $rawbody"); 307 308 # Bodies of real messages must be encoded for safe transmission. 309 # Message parts will get encoded on the moment the whole multipart 310 # is transformed into a real message. 311 312 my $body = $self->isPart ? $rawbody : $rawbody->encoded; 313 $body->contentInfoTo($self->head); 314 315 my $oldbody = $self->{MM_body}; 316 return $body if defined $oldbody && $body==$oldbody; 317 318 $body->message($self); 319 $body->modified(1) if defined $oldbody; 320 321 $self->{MM_body} = $body; 322} 323 324 325sub decoded(@) 326{ my $body = shift->body->load; 327 $body ? $body->decoded(@_) : undef; 328} 329 330 331sub encode(@) 332{ my $body = shift->body->load; 333 $body ? $body->encode(@_) : undef; 334} 335 336 337sub isMultipart() {shift->head->isMultipart} 338 339 340sub isNested() {shift->body->isNested} 341 342 343sub contentType() 344{ my $head = shift->head; 345 my $ct = (defined $head ? $head->get('Content-Type', 0) : undef) || ''; 346 $ct =~ s/\s*\;.*//; 347 length $ct ? $ct : 'text/plain'; 348} 349 350 351sub parts(;$) 352{ my $self = shift; 353 my $what = shift || 'ACTIVE'; 354 355 my $body = $self->body; 356 my $recurse = $what eq 'RECURSE' || ref $what; 357 358 my @parts 359 = $body->isNested ? $body->nested->parts($what) 360 : $body->isMultipart ? $body->parts($recurse ? 'RECURSE' : ()) 361 : $self; 362 363 ref $what eq 'CODE' ? (grep $what->($_), @parts) 364 : $what eq 'ACTIVE' ? (grep !$_->isDeleted, @parts) 365 : $what eq 'DELETED' ? (grep $_->isDeleted, @parts) 366 : $what eq 'ALL' ? @parts 367 : $recurse ? @parts 368 : confess "Select parts via $what?"; 369} 370 371#------------------------------------------ 372 373 374sub modified(;$) 375{ my $self = shift; 376 377 return $self->isModified unless @_; # compatibility 2.036 378 379 my $flag = shift; 380 $self->{MM_modified} = $flag; 381 my $head = $self->head; 382 $head->modified($flag) if $head; 383 my $body = $self->body; 384 $body->modified($flag) if $body; 385 386 $flag; 387} 388 389 390sub isModified() 391{ my $self = shift; 392 return 1 if $self->{MM_modified}; 393 394 my $head = $self->head; 395 if($head && $head->isModified) 396 { $self->{MM_modified}++; 397 return 1; 398 } 399 400 my $body = $self->body; 401 if($body && $body->isModified) 402 { $self->{MM_modified}++; 403 return 1; 404 } 405 406 0; 407} 408 409 410sub label($;$@) 411{ my $self = shift; 412 return $self->{MM_labels}{$_[0]} unless @_ > 1; 413 my $return = $_[1]; 414 415 my %labels = @_; 416 @{$self->{MM_labels}}{keys %labels} = values %labels; 417 $return; 418} 419 420 421sub labels() 422{ my $self = shift; 423 wantarray ? keys %{$self->{MM_labels}} : $self->{MM_labels}; 424} 425 426 427sub isDeleted() { shift->label('deleted') } 428 429 430sub delete() 431{ my $self = shift; 432 my $old = $self->label('deleted'); 433 $old || $self->label(deleted => time); 434} 435 436 437sub deleted(;$) 438{ my $self = shift; 439 440 @_ ? $self->label(deleted => shift) 441 : $self->label('deleted') # compat 2.036 442} 443 444 445sub labelsToStatus() 446{ my $self = shift; 447 my $head = $self->head; 448 my $labels = $self->labels; 449 450 my $status = $head->get('status') || ''; 451 my $newstatus 452 = $labels->{seen} ? 'RO' 453 : $labels->{old} ? 'O' 454 : ''; 455 456 $head->set(Status => $newstatus) 457 if $newstatus ne $status; 458 459 my $xstatus = $head->get('x-status') || ''; 460 my $newxstatus 461 = ($labels->{replied} ? 'A' : '') 462 . ($labels->{flagged} ? 'F' : ''); 463 464 $head->set('X-Status' => $newxstatus) 465 if $newxstatus ne $xstatus; 466 467 $self; 468} 469 470 471sub statusToLabels() 472{ my $self = shift; 473 my $head = $self->head; 474 475 if(my $status = $head->get('status')) 476 { $status = $status->foldedBody; 477 $self->label 478 ( seen => (index($status, 'R') >= 0) 479 , old => (index($status, 'O') >= 0) 480 ); 481 } 482 483 if(my $xstatus = $head->get('x-status')) 484 { $xstatus = $xstatus->foldedBody; 485 $self->label 486 ( replied => (index($xstatus, 'A') >= 0) 487 , flagged => (index($xstatus, 'F') >= 0) 488 ); 489 } 490 491 $self; 492} 493 494#------------------------------------------ 495 496 497my $mail_internet_converter; 498my $mime_entity_converter; 499my $email_simple_converter; 500 501sub coerce($@) 502{ my ($class, $message) = @_; 503 504 blessed $message 505 or die "coercion starts with some object"; 506 507 return $message 508 if ref $message eq $class; 509 510 if($message->isa(__PACKAGE__)) { 511 $message->head->modified(1); 512 $message->body->modified(1); 513 return bless $message, $class; 514 } 515 516 if($message->isa('MIME::Entity')) 517 { unless($mime_entity_converter) 518 { eval {require Mail::Message::Convert::MimeEntity}; 519 confess "Install MIME::Entity" if $@; 520 $mime_entity_converter = Mail::Message::Convert::MimeEntity->new; 521 } 522 523 $message = $mime_entity_converter->from($message) 524 or return; 525 } 526 527 elsif($message->isa('Mail::Internet')) 528 { unless($mail_internet_converter) 529 { eval {require Mail::Message::Convert::MailInternet}; 530 confess "Install Mail::Internet" if $@; 531 $mail_internet_converter = Mail::Message::Convert::MailInternet->new; 532 } 533 534 $message = $mail_internet_converter->from($message) 535 or return; 536 } 537 538 elsif($message->isa('Email::Simple')) 539 { unless($email_simple_converter) 540 { eval {require Mail::Message::Convert::EmailSimple}; 541 confess "Install Email::Simple" if $@; 542 $email_simple_converter = Mail::Message::Convert::EmailSimple->new; 543 } 544 545 $message = $email_simple_converter->from($message) 546 or return; 547 } 548 549 elsif($message->isa('Email::Abstract')) 550 { return $class->coerce($message->object); 551 } 552 553 else 554 { $class->log(INTERNAL => "Cannot coerce a ". ref($message) 555 . " object into a ". __PACKAGE__." object"); 556 } 557 558 $message->{MM_modified} ||= 0; 559 bless $message, $class; 560} 561 562 563sub clonedFrom() { shift->{MM_cloned} } 564 565#------------------------------------------ 566# All next routines try to create compatibility with release < 2.0 567sub isParsed() { not shift->isDelayed } 568sub headIsRead() { not shift->head->isDelayed } 569 570 571sub readFromParser($;$) 572{ my ($self, $parser, $bodytype) = @_; 573 574 my $head = $self->readHead($parser) 575 || Mail::Message::Head::Complete->new 576 ( message => $self 577 , field_type => $self->{MM_field_type} 578 , $self->logSettings 579 ); 580 581 my $body = $self->readBody($parser, $head, $bodytype) 582 or return; 583 584 $self->head($head); 585 $self->storeBody($body); 586 $self; 587} 588 589 590sub readHead($;$) 591{ my ($self, $parser) = (shift, shift); 592 593 my $headtype = shift 594 || $self->{MM_head_type} || 'Mail::Message::Head::Complete'; 595 596 $headtype->new 597 ( message => $self 598 , field_type => $self->{MM_field_type} 599 , $self->logSettings 600 )->read($parser); 601} 602 603 604my $mpbody = 'Mail::Message::Body::Multipart'; 605my $nbody = 'Mail::Message::Body::Nested'; 606my $lbody = 'Mail::Message::Body::Lines'; 607 608sub readBody($$;$$) 609{ my ($self, $parser, $head, $getbodytype) = @_; 610 611 my $bodytype 612 = ! $getbodytype ? ($self->{MM_body_type} || $lbody) 613 : ref $getbodytype ? $getbodytype->($self, $head) 614 : $getbodytype; 615 616 my $body; 617 if($bodytype->isDelayed) 618 { $body = $bodytype->new 619 ( message => $self 620 , charset => 'us-ascii' 621 , $self->logSettings 622 ); 623 } 624 else 625 { my $ct = $head->get('Content-Type', 0); 626 my $type = defined $ct ? lc($ct->body) : 'text/plain'; 627 628 # Be sure you have acceptable bodies for multiparts and nested. 629 if(substr($type, 0, 10) eq 'multipart/' && !$bodytype->isMultipart) 630 { $bodytype = $mpbody } 631 elsif($type eq 'message/rfc822' && !$bodytype->isNested) 632 { $bodytype = $nbody } 633 634 $body = $bodytype->new 635 ( message => $self 636 , checked => $self->{MM_trusted} 637 , charset => 'us-ascii' 638 , $self->logSettings 639 ); 640 641 $body->contentInfoFrom($head); 642 } 643 644 my $lines = $head->get('Lines'); # usually off-by-one 645 my $size = $head->guessBodySize; 646 647 $body->read 648 ( $parser, $head, $getbodytype, 649 , $size, (defined $lines ? $lines : undef) 650 ); 651} 652 653 654sub storeBody($) 655{ my ($self, $body) = @_; 656 $self->{MM_body} = $body; 657 $body->message($self); 658 $body; 659} 660 661 662sub isDelayed() 663{ my $body = shift->body; 664 !$body || $body->isDelayed; 665} 666 667 668sub takeMessageId(;$) 669{ my $self = shift; 670 my $msgid = (@_ ? shift : $self->get('Message-ID')) || ''; 671 672 if($msgid =~ m/\<([^>]*)\>/s) 673 { $msgid = $1; 674 $msgid =~ s/\s//gs; 675 } 676 677 $msgid = $self->head->createMessageId 678 unless length $msgid; 679 680 $self->{MM_message_id} = $msgid; 681} 682 683#------------------------------------------ 684 685 686sub shortSize(;$) 687{ my $self = shift; 688 my $size = shift; 689 $size = $self->head->guessBodySize unless defined $size; 690 691 !defined $size ? '?' 692 : $size < 1_000 ? sprintf "%3d " , $size 693 : $size < 10_000 ? sprintf "%3.1fK", $size/1024 694 : $size < 1_000_000 ? sprintf "%3.0fK", $size/1024 695 : $size < 10_000_000 ? sprintf "%3.1fM", $size/(1024*1024) 696 : sprintf "%3.0fM", $size/(1024*1024); 697} 698 699 700sub shortString() 701{ my $self = shift; 702 sprintf "%4s %-30.30s", $self->shortSize, $self->subject; 703} 704 705#------------------------------------------ 706 707 708sub destruct() { $_[0] = undef } 709 710#------------------------------------------ 711 712 7131; 714