1# Mail::MboxParser - object-oriented access to UNIX-mailboxes 2# 3# Copyright (C) 2001 Tassilo v. Parseval 4# This program is free software; you can redistribute it and/or 5# modify it under the same terms as Perl itself. 6 7# Version: $Id: Mail.pm,v 1.53 2005/11/23 09:30:12 parkerpine Exp $ 8 9package Mail::MboxParser::Mail; 10 11require 5.004; 12 13use base qw(Exporter Mail::MboxParser::Base); 14 15# ---------------------------------------------------------------- 16 17=head1 NAME 18 19Mail::MboxParser::Mail - Provide mail-objects and methods upon 20 21=head1 SYNOPSIS 22 23See L<Mail::MboxParser> for an outline on usage. Examples however are also 24provided in this manpage further below. 25 26=head1 DESCRIPTION 27 28Mail::MboxParser::Mail objects are usually not created directly though, in 29theory, they could be. A description of the provided methods can be found in 30L<Mail::MboxParser>. 31 32However, go on reading if you want to use methods from MIME::Entity and learn 33about overloading. 34 35=head1 METHODS 36 37=cut 38 39use Mail::MboxParser::Mail::Body; 40use Mail::MboxParser::Mail::Convertable; 41use Carp; 42 43use strict; 44use vars qw($VERSION @EXPORT $AUTOLOAD $NL); 45$VERSION = "0.45"; 46@EXPORT = qw(); 47 48# we'll use it to store the MIME::Parser 49my $Parser; 50 51use overload '""' => \&as_string, fallback => 1; 52 53BEGIN { $Mail::MboxParser::Mail::NL = "\n" } 54 55use constant 56 HAVE_ENCODE => eval { require Encode; 1 } || 0; 57use constant 58 HAVE_MIMEWORDS => eval { require MIME::Words; 1 } || 0; 59 60# ---------------------------------------------------------------- 61 62=over 4 63 64=item B<new(header, body)> 65 66This is usually not called directly but instead by C<get_messages()>. You could 67however create a mail-object manually providing the header and body each as 68either one string or as an array-ref representing the lines. 69 70Here is a common scenario: Retrieving mails from a remote POP-server using 71Mail::POP3Client and directly feeding each mail to 72C<Mail::MboxParser::Mail-E<gt>new>: 73 74 use Mail::POP3Client; 75 use Mail::MboxParser::Mail; 76 77 my $pop = new Mail::POP3Client (...); 78 79 for my $i (1 .. $pop->Count) { 80 my $msg = Mail::MboxParser::Mail->new( [ $pop->Head($i) ], 81 [ $pop->Body($i) ] ); 82 $msg->store_all_attachments( path => '/home/user/dump' ); 83 } 84 85The above effectively behaves like an attachment-only retriever. 86 87=back 88 89=cut 90 91sub init (@) { 92 my ($self, @args) = @_; 93 my ($header, $body, $conf) = @args; 94 95 $self->{HEADER} = ref $header ? $header : [ split /$NL/, $header ]; 96 $self->{HEADER_HASH} = \&_split_header; 97 $self->{BODY} = ref $body ? $body : [ split /$NL/, $body ]; 98 $self->{TOP_ENTITY} = 0; 99 $self->{ARGS} = $conf; 100 101 if (! $self->{ARGS}->{uudecode} ) { 102 # set default for 'uudecode' option 103 $self->{ARGS}->{uudecode} = 0; 104 } 105 106 # make sure line-endings are ok if called directly 107 if (caller(1) ne 'Mail::MboxParser') { 108 $self->{ARGS}->{join_string} = ''; 109 for (@{ $self->{HEADER} }, @{ $self->{BODY} }) { 110 $_ .= "\n" unless /.*\n$/; 111 } 112 push @{ $self->{HEADER} }, "\n" if $self->{HEADER}->[-1] ne "\n"; 113 } 114 $self; 115} 116 117# ---------------------------------------------------------------- 118 119=over 4 120 121=item B<header> 122 123Returns the mail-header as a hash-ref with header-fields as keys. All keys are 124turned to lower-case, so C<$header{Subject}> has to be written as 125C<$header{subject}>. 126 127If a header-field occurs more than once in the header, the value of the key is 128an array_ref. Example: 129 130 my $field = $msg->header->{field}; 131 print $field->[0]; # first occurance of 'field' 132 print $field->[1]; # second one 133 ... 134 135=back 136 137=cut 138 139sub header() { 140 my $self = shift; 141 my $decode = $self->{ARGS}->{decode} || 'NEVER'; 142 $self->reset_last; 143 144 return $self->{HEADER_HASH}->($self, $self->{HEADER}, $decode); 145} 146 147# ---------------------------------------------------------------- 148 149=over 4 150 151=item B<from_line> 152 153Returns the "From "-line of the message. 154 155=back 156 157=cut 158 159sub from_line() { 160 my $self = shift; 161 $self->reset_last; 162 163 $self->{HEADER_HASH}->($self, $self->{HEADER}, 'NEVER') 164 if !exists $self->{FROM}; 165 166 if (! exists $self->{FROM}) { 167 $self->{LAST_ERR} = "Message did not contain a From-line"; 168 return; 169 } 170 $self->{FROM}; 171} 172 173# ---------------------------------------------------------------- 174 175=over 4 176 177=item B<trace> 178 179This method returns the "Received: "-lines of the message as a list. 180 181=back 182 183=cut 184 185sub trace () { 186 my $self = shift; 187 $self->reset_last; 188 189 $self->{HEADER_HASH}->($self, $self->{HEADER}, 'NEVER') 190 if ! exists $self->{TRACE}; 191 192 if (! exists $self->{TRACE}) { 193 $self->{LAST_ERR} = "Message did not contain any Received-lines"; 194 return; 195 } 196 197 @{ $self->{TRACE} }; 198} 199 200# ---------------------------------------------------------------- 201 202=over 4 203 204=item B<body> 205 206=item B<body(n)> 207 208Returns a Mail::MboxParser::Mail::Body object. For methods upon that see 209further below. When called with the argument n, the n-th body of the message is 210retrieved. That is, the body of the n-th entity. 211 212Sets C<$mail-E<gt>error> if something went wrong. 213 214=back 215 216=cut 217 218sub body(;$) { 219 my ($self, $num) = @_; 220 $self->reset_last; 221 222 if (defined $num && $num >= $self->num_entities) { 223 $self->{LAST_ERR} = "No such body"; 224 return; 225 } 226 227 # body needs the "Content-type: ... boundary=" stuff 228 # in order to decide which lines are part of signature and 229 # which lines are not (ie denote a MIME-part) 230 my $bound; 231 232 # particular entity desired? 233 # we need to read the header of this entity then :-( 234 if (defined $num) { 235 my $ent = $self->get_entities($num); 236 if ($bound = $ent->head->get('content-type')) { 237 $bound =~ /boundary="(.*)"/; $bound = $1; 238 } 239 return Mail::MboxParser::Mail::Body->new($ent, $bound, $self->{ARGS}); 240 } 241 242 # else 243 if ($bound = $self->header->{'content-type'}) { 244 $bound =~ /boundary="(.*)"/; $bound = $1; 245 } 246 return ref $self->{TOP_ENTITY} eq 'MIME::Entity' 247 ? Mail::MboxParser::Mail::Body->new($self->{TOP_ENTITY}, $bound, $self->{ARGS}) 248 : Mail::MboxParser::Mail::Body->new(scalar $self->get_entities(0), $bound, $self->{ARGS}); 249} 250 251# ---------------------------------------------------------------- 252 253=over 4 254 255=item B<find_body> 256 257This will return an index number that represents what Mail::MboxParser::Mail 258considers to be the actual (main)-body of an email. This is useful if you don't 259know about the structure of a message but want to retrieve the message's 260signature for instance: 261 262 $signature = $msg->body($msg->find_body)->signature; 263 264Changes are good that find_body does what it is supposed to do. 265 266=back 267 268=cut 269 270sub find_body() { 271 my $self = shift; 272 $self->{LAST_ERR} = "Could not find a suitable body at all"; 273 my $num = -1; 274 for my $part ($self->parts_DFS) { 275 $num++; 276 if ($part->effective_type eq 'text/plain') { 277 $self->reset_last; last; 278 } 279 } 280 return $num; 281} 282 283# ---------------------------------------------------------------- 284 285=over 4 286 287=item B<make_convertable> 288 289Returns a Mail::MboxParser::Mail::Convertable object. For details on what you 290can do with it, read L<Mail::MboxParser::Mail::Convertable>. 291 292=back 293 294=cut 295 296sub make_convertable(@) { 297 my $self = shift; 298 return ref $self->{TOP_ENTITY} eq 'MIME::Entity' 299 ? Mail::MboxParser::Mail::Convertable->new($self->{TOP_ENTITY}) 300 : Mail::MboxParser::Mail::Convertable->new($self->get_entities(0)); 301} 302 303# ---------------------------------------------------------------- 304 305=over 4 306 307=item B<get_field(headerfield)> 308 309Returns the specified raw field from the message header, that is: the fieldname 310is not stripped off nor is any decoding done. Returns multiple lines as needed 311if the field is "Received" or another multi-line field. Not case sensitive. 312 313C<get_field()> always returns one string regardless of how many times the field 314occured in the header. Multiple occurances are separated by a newline and 315multiple whitespaces squeezed to one. That means you can process each occurance 316of the field thusly: 317 318 for my $field ( split /\n/, $msg->get_field('received') ) { 319 # do something with $field 320 } 321 322Sets C<$mail-E<gt>error> if the field was not found in which case 323C<get_field()> returns C<undef>. 324 325=back 326 327=cut 328 329sub get_field($) { 330 my ($self, $fieldname) = @_; 331 $self->reset_last; 332 333 my @headerlines = ref $self->{HEADER} 334 ? @{$self->{HEADER}} 335 : split /$NL/, $self->{HEADER}; 336 chomp @headerlines; 337 338 my ($ret, $inretfield); 339 foreach my $bit (@headerlines) { 340 if ($bit =~ /^\s/) { 341 if ($inretfield) { 342 $bit =~ s/\s+/ /g; 343 $ret .= $bit; 344 } 345 } 346 elsif ($bit =~ /^$fieldname/i) { 347 $bit =~ s/\s+/ /g; 348 $inretfield++; 349 if (defined $ret) { $ret .= "\n" . $bit } 350 else { $ret .= $bit } 351 } 352 else { $inretfield = 0; } 353 } 354 355 $self->{LAST_ERR} = "No such field" if not $ret; 356 return $ret; 357} 358 359# ---------------------------------------------------------------- 360 361=over 4 362 363=item B<from> 364 365Returns a hash-ref with the two fields 'name' and 'email'. Returns C<undef> if 366empty. The name-field does not necessarily contain a value either. Example: 367 368 print $mail->from->{email}; 369 370On behalf of suggestions I received from users, from() tries to be smart when 371'name'is empty and 'email' has the form 'first.name@host.com'. In this case, 372'name' is set to "First Name". 373 374=back 375 376=cut 377 378sub from() { 379 my $self = shift; 380 $self->reset_last; 381 382 my $from = $self->header->{from}; 383 my ($name, $email) = split /\s\</, $from; 384 $email =~ s/\>$//g unless not $email; 385 if ($name && ! $email) { 386 $email = $name; 387 $name = ""; 388 $name = ucfirst($1) . " " . ucfirst($2) if $email =~ /^(.*?)\.(.*)@/; 389 } 390 return {(name => $name, email => $email)}; 391} 392 393# ---------------------------------------------------------------- 394 395=over 4 396 397=item B<to> 398 399Returns an array of hash-references of all to-fields in the mail-header. Fields 400are the same as those of C<$mail-E<gt>from>. Example: 401 402 for my $recipient ($mail->to) { 403 print $recipient->{name} || "<no name>", "\n"; 404 print $recipient->{email}; 405 } 406 407The same 'name'-smartness applies here as described under C<from()>. 408 409=back 410 411=cut 412 413sub to() { shift->_recipients("to") } 414 415# ---------------------------------------------------------------- 416 417=over 4 418 419=item B<cc> 420 421Identical with to() but returning the hash-refed "Cc: "-line. 422 423The same 'name'-smartness applies here as described under C<from()>. 424 425=back 426 427=cut 428 429sub cc() { shift->_recipients("cc") } 430 431# ---------------------------------------------------------------- 432 433=over 4 434 435=item B<id> 436 437Returns the message-id of a message cutting off the leading and trailing '<' 438and '>' respectively. 439 440=back 441 442=cut 443 444sub id() { 445 my $self = shift; 446 $self->reset_last; 447 $self->header->{'message-id'} =~ /\<(.*)\>/; 448 $1; 449} 450 451# ---------------------------------------------------------------- 452 453# -------------------- 454# MIME-related methods 455#--------------------- 456 457# ---------------------------------------------------------------- 458 459=over 4 460 461=item B<num_entities> 462 463Returns the number of MIME-entities. That is, the number of sub-entitities 464actually. If 0 is returned and you think this is wrong, check 465C<$mail-E<gt>log>. 466 467=back 468 469=cut 470 471sub num_entities() { 472 my $self = shift; 473 $self->reset_last; 474 # force list contest becaus of wantarray in get_entities 475 $self->{NUM_ENT} = () = $self->get_entities unless defined $self->{NUM_ENT}; 476 return $self->{NUM_ENT}; 477} 478 479# ---------------------------------------------------------------- 480 481=over 4 482 483=item B<get_entities> 484 485=item B<get_entities(n)> 486 487Either returns an array of all MIME::Entity objects or one particular if called 488with a number. If no entity whatsoever could be found, an empty list is 489returned. 490 491C<$mail-E<gt>log> instantly called after get_entities will give you some 492information of what internally may have failed. If set, this will be an error 493raised by MIME::Entity but you don't need to worry about it at all. It's just 494for the record. 495 496=back 497 498=cut 499 500sub get_entities(@) { 501 my ($self, $num) = @_; 502 $self->reset_last; 503 504 if (defined $num && $num >= $self->num_entities) { 505 $self->{LAST_ERR} = "No such entity"; 506 return; 507 } 508 509 if (ref $self->{TOP_ENTITY} ne 'MIME::Entity') { 510 511 if (! defined $Parser) { 512 eval { require MIME::Parser; }; 513 $Parser = new MIME::Parser; $Parser->output_to_core(1); 514 $Parser->extract_uuencode($self->{ARGS}->{uudecode}); 515 } 516 517 my $data = $self->as_string; 518 $self->{TOP_ENTITY} = $Parser->parse_data($data); 519 } 520 521 my @parts = eval { $self->{TOP_ENTITY}->parts_DFS; }; 522 $self->{LAST_LOG} = $@ if $@; 523 return wantarray ? @parts : $parts[$num]; 524} 525 526# ---------------------------------------------------------------- 527 528# just overriding MIME::Entity::parts() 529# to work around its strange behaviour 530 531sub parts(@) { shift->get_entities(@_) } 532 533# ---------------------------------------------------------------- 534 535=over 4 536 537=item B<get_entity_body(n)> 538 539Returns the body of the n-th MIME::Entity as a single string, undef otherwise 540in which case you could check C<$mail-E<gt>error>. 541 542=back 543 544=cut 545 546sub get_entity_body($) { 547 my $self = shift; 548 my $num = shift; 549 $self->reset_last; 550 551 if ($num < $self->num_entities && 552 $self->get_entities($num)->bodyhandle) { 553 return $self->get_entities($num)->bodyhandle->as_string; 554 } 555 else { 556 $self->{LAST_ERR} = "$num: No such entity"; 557 return; 558 } 559} 560 561# ---------------------------------------------------------------- 562 563=over 4 564 565=item B<store_entity_body(n, handle =E<gt> FILEHANDLE)> 566 567Stores the stringified body of n-th entity to the specified filehandle. That's 568basically the same as: 569 570 my $body = $mail->get_entity_body(0); 571 print FILEHANDLE $body; 572 573and could be shortened to this: 574 575 $mail->store_entity_body(0, handle => \*FILEHANDLE); 576 577It returns a true value on success and undef on failure. In this case, examine 578the value of $mail->error since the entity you specified with 'n' might not 579exist. 580 581=back 582 583=cut 584 585sub store_entity_body($@) { 586 my $self = shift; 587 my ($num, %args) = @_; 588 $self->reset_last; 589 590 if (not $num || (not exists $args{handle} && 591 ref $args{handle} ne 'GLOB')) { 592 croak <<EOC; 593Wrong number or type of arguments for store_entity_body. Second argument must 594have the form handle => \*FILEHANDLE. 595EOC 596 } 597 598 binmode $args{handle}; 599 my $b = $self->get_entity_body($num); 600 print { $args{handle} } $b if defined $b; 601 return 1; 602} 603 604# ---------------------------------------------------------------- 605 606=over 4 607 608=item B<store_attachment(n)> 609 610=item B<store_attachment(n, options)> 611 612It is really just a call to store_entity_body but it will take care that the 613n-th entity really is a saveable attachment. That is, it wont save anything 614with a MIME-type of, say, text/html or so. 615 616Unless further 'options' have been given, an attachment (if found) is stored 617into the current directory under the recommended filename given in the 618MIME-header. 'options' are specified in key/value pairs: 619 620 key: | value: | description: 621 ===========|================|=============================== 622 path | relative or | directory to store attachment 623 (".") | absolute | 624 | path | 625 -----------|----------------|------------------------------- 626 encode | encoding | Some platforms store files 627 | suitable for | in e.g. UTF-8. Specify the 628 | Encode::encode | appropriate encoding here and 629 | | and the filename will be en- 630 | | coded accordingly. 631 -----------|----------------|------------------------------- 632 store_only | a compiled | store only files whose file 633 | regex-pattern | names match this pattern 634 -----------|----------------|------------------------------- 635 code | an anonym | first argument will be the 636 | subroutine | $msg-object, second one the 637 | | index-number of the current 638 | | MIME-part 639 | | should return a filename for 640 | | the attachment 641 -----------|----------------|------------------------------- 642 prefix | prefix for | all filenames are prefixed 643 | filenames | with this value 644 -----------|----------------|------------------------------- 645 args | additional | this array-ref will be passed 646 | arguments as | on to the 'code' subroutine 647 | array-ref | as a dereferenced array 648 649 650Example: 651 652 $msg->store_attachment(1, 653 path => "/home/ethan/", 654 code => sub { 655 my ($msg, $n, @args) = @_; 656 return $msg->id."+$n"; 657 }, 658 args => [ "Foo", "Bar" ]); 659 660This will save the attachment found in the second entity under the name that 661consists of the message-ID and the appendix "+1" since the above code works on 662the second entity (that is, with index = 1). 'args' isn't used in this example 663but should demonstrate how to pass additional arguments. Inside the 'code' sub, 664@args equals ("Foo", "Bar"). 665 666If 'path' does not exist, it will try to create the directory for you. 667 668You can specify to save only files matching a certain pattern. To do that, use 669the store-only switch: 670 671 $msg->store_attachment(1, path => "/home/ethan/", 672 store_only => qr/\.jpg$/i); 673 674The above will only save files that end on '.jpg', not case-sensitive. You 675could also use a non-compiled pattern if you want, but that would make for 676instance case-insensitive matching a little cumbersome: 677 678 store_only => '(?i)\.jpg$' 679 680If you are working on a platform that requires a certain encoding for filenames 681on disk, you can use the 'encode' option. This becomes necessary for instance on 682Mac OS X which internally is UTF-8 based. If the filename contains 8bit characters 683(like the German umlauts or French accented characters as in '�'), storing the 684attachment under a non-encoded name will most likely fail. In this case, use something 685like this: 686 687 $msg->store_attachment(1, path => '/tmp', encode => 'utf-8'); 688 689See L<Encode::Supported> for a list of encodings that you may use. 690 691Returns the filename under which the attachment has been saved. undef is 692returned in case the entity did not contain a saveable attachement, there was 693no such entity at all or there was something wrong with the 'path' you 694specified. Check C<$mail-E<gt>error> to find out which of these possibilities 695apply. 696 697=back 698 699=cut 700 701sub store_attachment($@) { 702 my $self = shift; 703 my ($num, %args) = @_; 704 $self->reset_last; 705 706 my $path = $args{path} || "."; 707 $path =~ s/\/$//; 708 709 my $prefix = $args{prefix} || ""; 710 711 if (defined $args{code} && ref $args{code} ne 'CODE') { 712 carp <<EOW; 713Warning: Second argument for store_attachment must be 714a coderef. Using filename from header instead 715EOW 716 delete @args{ qw(code args) }; 717 } 718 719 if ($num < $self->num_entities) { 720 my $file = $self->_get_attachment( $num ); 721 return if ! defined $file; 722 723 if (-e $path && not -d _) { 724 $self->{LAST_ERR} = "$path is a file"; 725 return; 726 } 727 728 if (not -e _) { 729 if (not mkdir $path, 0755) { 730 $self->{LAST_ERR} = "Could not create directory $path: $!"; 731 return; 732 } 733 } 734 735 if (defined $args{code}) { 736 $file = $args{code}->($self, $num, @{$args{args}}) 737 } 738 739 #if ($file =~ /=\?.*\?=/ and HAVE_MIMEWORDS) { # decode qp if possible 740 # $file = MIME::Words::decode_mimewords($file); 741 #} 742 743 return if defined $args{store_only} and $file !~ /$args{store_only}/; 744 745 if ($args{encode} and HAVE_ENCODE) { 746 $file = Encode::encode($args{encode}, $file); 747 } 748 749 local *ATT; 750 if (open ATT, ">$path/$prefix$file") { 751 $self->store_entity_body($num, handle => \*ATT); 752 close ATT ; 753 return "$prefix$file"; 754 755 } 756 else { 757 $self->{LAST_ERR} = "Could not create $path/$prefix$file: $!"; 758 return; 759 } 760 } 761 else { 762 $self->{LAST_ERR} = "$num: No such entity"; 763 return; 764 } 765} 766 767# ---------------------------------------------------------------- 768 769=over 4 770 771=item B<store_all_attachments> 772 773=item B<store_all_attachments(options)> 774 775Walks through an entire mail and stores all apparent attachments. 'options' are 776exactly the same as in C<store_attachement()> with the same behaviour if no 777options are given. 778 779Returns a list of files that have been succesfully saved and an empty list if 780no attachment could be extracted. 781 782C<$mail-E<gt>error> will tell you possible failures and a possible explanation 783for that. 784 785=back 786 787=cut 788 789sub store_all_attachments(@) { 790 my $self = shift; 791 my %args = @_; 792 $self->reset_last; 793 794 if (defined $args{code} and ref $args{code} ne 'CODE') { 795 carp <<EOW; 796Warning: Second argument for store_all_attachments must be a coderef. 797Using filename from header instead 798EOW 799 delete @args{ qw(code args) }; 800 } 801 my @files; 802 803 if (! exists $args{path} || $args{path} eq '') { 804 $args{path} = '.'; 805 } 806 807 for (0 .. $self->num_entities - 1) { 808 push @files, $self->store_attachment($_, %args); 809 } 810 811 $self->{LAST_ERR} = "Found no attachment at all" if ! @files; 812 return @files; 813} 814 815# ---------------------------------------------------------------- 816 817=over 4 818 819=item B<get_attachments> 820 821=item B<get_attachments(file)> 822 823This method returns a mapping from attachment-names (if those are savable) to 824index-numbers of the MIME-part that represents this attachment. It returns a 825hash-reference, the file-names being the key and the index the value: 826 827 my $mapping = $msg->get_attachments; 828 for my $filename (keys %$mapping) { 829 print "$filename => $mapping->{$filename}\n"; 830 } 831 832If called with a string as argument, it tries to look up this filename. If it 833can't be found, undef is returned. In this case you also should have an 834error-message patiently awaiting you in the return value of 835C<$mail-E<gt>error>. 836 837Even though it looks tempting, don't do the following: 838 839 # BAD! 840 841 for my $file (qw/file1.ext file2.ext file3.ext file4.ext/) { 842 print "$file is in message ", $msg->id, "\n" 843 if defined $msg->get_attachments($file); 844 } 845 846The reason is that C<get_attachments()> is currently B<not> optimized to cache 847the filename mapping. So, each time you call it on (even the same) message, it 848will scan it from beginning to end. Better would be: 849 850 # GOOD! 851 852 my $mapping = $msg->get_attachments; 853 for my $file (qw/file1.ext file2.ext file3.ext file4.ext/) { 854 print "$file is in message ", $msg->id, "\n" 855 if exists $mapping->{$file}; 856 } 857 858=back 859 860=cut 861 862sub get_attachments(;$) { 863 my ($self, $name) = @_; 864 $self->reset_last; 865 my %mapping; 866 867 for my $num (0 .. $self->num_entities - 1) { 868 my $file = $self->_get_attachment($num); 869 $mapping{ $file } = $num if defined $file; 870 } 871 872 if ($name) { 873 if (! exists $mapping{$name}) { 874 $self->{LAST_ERR} = "$name: No such attachment"; 875 return; 876 } else { 877 return $mapping{$name} 878 } 879 } 880 881 if (keys %mapping == 0) { 882 $self->{LAST_ERR} = "No attachments at all"; 883 return; 884 } 885 886 return \%mapping; 887} 888 889sub _get_attachment { 890 my ($self, $num) = @_; 891 my $file = eval { $self->get_entities($num)->head->recommended_filename }; 892 $self->{LAST_LOG} = $@; 893 if (! $file) { 894 # test for Content-Disposition 895 if (! $self->get_entities($num)->head->get('content-disposition')) { 896 return; 897 } else { 898 my ($type, $filename) = split /;\s*/, 899 $self->get_entities($num)->head->get('content-disposition'); 900 if ($type eq 'attachment') { 901 if ($filename =~ /filename\*?=(.*?''?)?(.*)$/) { 902 ($file = $2) =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; 903 } 904 } 905 } 906 } 907 908 return if not $file; 909 910 if ($file =~ /=\?.*\?=/ and HAVE_MIMEWORDS) { # decode qp if possible 911 $file = MIME::Words::decode_mimewords($file); 912 } 913 914 return $file; 915} 916 917# ---------------------------------------------------------------- 918 919=over 4 920 921=item B<as_string> 922 923Returns the message as one string. This is the method that string overloading 924depends on, so these two are the same: 925 926 print $msg; 927 928 print $msg->as_string; 929 930=back 931 932=cut 933 934sub as_string { 935 my $self = shift; 936 my $js = $self->{ARGS}->{join_string}; 937 return join $js, @{ $self->{HEADER} }, @{ $self->{BODY} }; 938} 939 940sub _recipients($) { 941 my ($self, $field) = @_; 942 $self->reset_last; 943 944 my $rec = $self->header->{$field}; 945 if (! $rec) { 946 $self->{LAST_ERR} = "'$field' not in header"; 947 return; 948 } 949 950 $rec =~ s/(?<=\@)(.*?),/$1\n/g; 951 my @recs = split /\n/, $rec; 952 s/^\s+//, s/\s+$// for @recs; # remove leading or trailing whitespaces 953 my @rec_line; 954 for my $pair (@recs) { 955 my ($name, $email) = split /\s</, $pair; 956 $email =~ s/\>$//g if $email; 957 if ($name && ! $email) { 958 $email = $name; 959 $name = ""; 960 $name = ucfirst($1) . " " . ucfirst($2) if $email =~ /^(.*?)\.(.*)@/; 961 } 962 push @rec_line, {(name => $name, email => $email)}; 963 } 964 965 return @rec_line; 966} 967 968# patch provided by Kenn Frankel 969# additional corrections by Nathan Uno 970sub _split_header { 971 local $/ = $NL; 972 my ($self, $header, $decode) = @_; 973 my @headerlines = @{ $header }; 974 975 my @header; 976 chomp @headerlines if ref $header; 977 foreach my $bit (@headerlines) { 978 $bit =~ s/\s+$//; # discard trailing whitespace 979 if ($bit =~ s/^\s+/ /) { $header[-1] .= $bit } 980 else { push @header, $bit } 981 } 982 983 my ($key, $value); 984 my %header; 985 for (@header) { 986 if (/^Received:\s/) { push @{$self->{TRACE}}, substr($_, 10) } 987 elsif (/^From /) { $self->{FROM} = $_ } 988 else { 989 my $idx = index $_, ": "; 990 $key = substr $_, 0, $idx; 991 $value = $idx != -1 ? substr $_, $idx + 2 : ""; 992 if ($decode eq 'ALL' || $decode eq 'HEADER') { 993 use MIME::Words qw(:all); 994 $value = decode_mimewords($value); 995 } 996 997 # if such a field is already there => make array-ref 998 if (exists $header{lc($key)}) { 999 my $elem = $header{lc($key)}; 1000 my @data = ref $elem ? @$elem : $elem; 1001 push @data, $value; 1002 $header{lc($key)} = [ @data ]; 1003 } 1004 else { 1005 $header{lc($key)} = $value; 1006 } 1007 } 1008 } 1009 return \%header; 1010} 1011 1012sub AUTOLOAD { 1013 my ($self, @args) = @_; 1014 (my $call = $AUTOLOAD) =~ s/.*:://; 1015 1016 # for backward-compatibility 1017 if ($call eq 'store_attachement') { 1018 return $self->store_attachment(@args); 1019 } 1020 if ($call eq 'store_all_attachements') { 1021 return $self->store_all_attachments(@args); 1022 } 1023 1024 # test some potential classes that might implement $call 1025 { no strict 'refs'; 1026 for my $class (qw/MIME::Entity Mail::Internet/) { 1027 eval "require $class"; 1028 # we found a Class that implements $call 1029 if ($class->can($call)) { 1030 1031 # MIME::Entity needed 1032 if ($class eq 'MIME::Entity') { 1033 1034 if (! defined $Parser) { 1035 eval { require MIME::Parser }; 1036 $Parser = new MIME::Parser; 1037 $Parser->output_to_core(1); 1038 $Parser->extract_uuencode($self->{ARGS}->{uudecode}); 1039 } 1040 my $js = $self->{ARGS}->{join_string}; 1041 $self->{TOP_ENTITY} = $Parser->parse_data(join $js, @{$self->{HEADER}}, @{$self->{BODY}}) 1042 if ref $self->{TOP_ENTITY} ne 'MIME::Entity'; 1043 return $self->{TOP_ENTITY}->$call(@args); 1044 } 1045 1046 # Mail::Internet needed 1047 if ($class eq 'Mail::Internet') { 1048 return Mail::Internet->new([ split /\n/, join "", ref $self->{HEADER} 1049 ? @{$self->{HEADER}} 1050 : $self->{HEADER} . $self->{BODY} ]); 1051 } 1052 } 1053 } # end 'for' 1054 } # end 'no strict refs' block 1055} 1056 1057sub DESTROY { 1058} 1059 1060 10611; 1062 1063__END__ 1064 1065=head1 EXTERNAL METHODS 1066 1067Mail::MboxParser::Mail implements an autoloader that will do the appropriate 1068type-casts for you if you invoke methods from external modules. This, however, 1069currently only works with MIME::Entity. Support for other modules will follow. 1070Example: 1071 1072 my $mb = Mail::MboxParser->new("/home/user/Mail/received"); 1073 for my $msg ($mb->get_messages) { 1074 print $msg->effective_type, "\n"; 1075 } 1076 1077C<effective_type()> is not implemented by Mail::MboxParser::Mail and thus the 1078corresponding method of MIME::Entity is automatically called. 1079 1080To learn about what methods might be useful for you, you should read the 1081"Access"-part of the section "PUBLIC INTERFACE" in the MIME::Entity manpage. 1082It may become handy if you have mails with a lot of MIME-parts and you not just 1083want to handle binary-attachments but any kind of MIME-data. 1084 1085=head1 OVERLOADING 1086 1087Mail::MboxParser::Mail overloads the " " operator. Overloading operators is a 1088fancy feature of Perl and some other languages (C++ for instance) which will 1089change the behaviour of an object when one of those overloaded operators is 1090applied onto it. Here you get the stringified mail when you write C<$mail> 1091while otherwise you'd get the stringified reference: 1092C<Mail::MboxParser::Mail=HASH(...)>. 1093 1094=head1 VERSION 1095 1096This is version 0.55. 1097 1098=head1 AUTHOR AND COPYRIGHT 1099 1100Tassilo von Parseval <tassilo.von.parseval@rwth-aachen.de> 1101 1102Copyright (c) 2001-2005 Tassilo von Parseval. 1103This program is free software; you can redistribute it and/or 1104modify it under the same terms as Perl itself. 1105 1106=head1 SEE ALSO 1107 1108L<MIME::Entity> 1109 1110L<Mail::MboxParser>, L<Mail::MboxParser::Mail::Body>, L<Mail::MboxParser::Mail::Convertable> 1111 1112=cut 1113