File Coverage

blib/lib/MIME/Entity.pm
Criterion Covered Total %
statement 335 397 84.3
branch 151 234 64.5
condition 40 71 56.3
subroutine 42 49 85.7
pod 31 37 83.7
total 599 788 76.0


line stmt bran cond sub pod time code
1             package MIME::Entity;
2              
3              
4             =head1 NAME
5              
6             MIME::Entity - class for parsed-and-decoded MIME message
7              
8              
9             =head1 SYNOPSIS
10              
11             Before reading further, you should see L to make sure that
12             you understand where this module fits into the grand scheme of things.
13             Go on, do it now. I'll wait.
14              
15             Ready? Ok...
16              
17             ### Create an entity:
18             $top = MIME::Entity->build(From => 'me@myhost.com',
19             To => 'you@yourhost.com',
20             Subject => "Hello, nurse!",
21             Data => \@my_message);
22              
23             ### Attach stuff to it:
24             $top->attach(Path => $gif_path,
25             Type => "image/gif",
26             Encoding => "base64");
27              
28             ### Sign it:
29             $top->sign;
30              
31             ### Output it:
32             $top->print(\*STDOUT);
33              
34              
35             =head1 DESCRIPTION
36              
37             A subclass of B.
38              
39             This package provides a class for representing MIME message entities,
40             as specified in RFCs 2045, 2046, 2047, 2048 and 2049.
41              
42              
43             =head1 EXAMPLES
44              
45             =head2 Construction examples
46              
47             Create a document for an ordinary 7-bit ASCII text file (lots of
48             stuff is defaulted for us):
49              
50             $ent = MIME::Entity->build(Path=>"english-msg.txt");
51              
52             Create a document for a text file with 8-bit (Latin-1) characters:
53              
54             $ent = MIME::Entity->build(Path =>"french-msg.txt",
55             Encoding =>"quoted-printable",
56             From =>'jean.luc@inria.fr',
57             Subject =>"C'est bon!");
58              
59             Create a document for a GIF file (the description is completely optional;
60             note that we have to specify content-type and encoding since they're
61             not the default values):
62              
63             $ent = MIME::Entity->build(Description => "A pretty picture",
64             Path => "./docs/mime-sm.gif",
65             Type => "image/gif",
66             Encoding => "base64");
67              
68             Create a document that you already have the text for, using "Data":
69              
70             $ent = MIME::Entity->build(Type => "text/plain",
71             Encoding => "quoted-printable",
72             Data => ["First line.\n",
73             "Second line.\n",
74             "Last line.\n"]);
75              
76             Create a multipart message, with the entire structure given
77             explicitly:
78              
79             ### Create the top-level, and set up the mail headers:
80             $top = MIME::Entity->build(Type => "multipart/mixed",
81             From => 'me@myhost.com',
82             To => 'you@yourhost.com',
83             Subject => "Hello, nurse!");
84              
85             ### Attachment #1: a simple text document:
86             $top->attach(Path=>"./testin/short.txt");
87              
88             ### Attachment #2: a GIF file:
89             $top->attach(Path => "./docs/mime-sm.gif",
90             Type => "image/gif",
91             Encoding => "base64");
92              
93             ### Attachment #3: text we'll create with text we have on-hand:
94             $top->attach(Data => $contents);
95              
96             Suppose you don't know ahead of time that you'll have attachments?
97             No problem: you can "attach" to singleparts as well:
98              
99             $top = MIME::Entity->build(From => 'me@myhost.com',
100             To => 'you@yourhost.com',
101             Subject => "Hello, nurse!",
102             Data => \@my_message);
103             if ($GIF_path) {
104             $top->attach(Path => $GIF_path,
105             Type => 'image/gif');
106             }
107              
108             Copy an entity (headers, parts... everything but external body data):
109              
110             my $deepcopy = $top->dup;
111              
112              
113              
114             =head2 Access examples
115              
116             ### Get the head, a MIME::Head:
117             $head = $ent->head;
118              
119             ### Get the body, as a MIME::Body;
120             $bodyh = $ent->bodyhandle;
121              
122             ### Get the intended MIME type (as declared in the header):
123             $type = $ent->mime_type;
124              
125             ### Get the effective MIME type (in case decoding failed):
126             $eff_type = $ent->effective_type;
127              
128             ### Get preamble, parts, and epilogue:
129             $preamble = $ent->preamble; ### ref to array of lines
130             $num_parts = $ent->parts;
131             $first_part = $ent->parts(0); ### an entity
132             $epilogue = $ent->epilogue; ### ref to array of lines
133              
134              
135             =head2 Manipulation examples
136              
137             Muck about with the body data:
138              
139             ### Read the (unencoded) body data:
140             if ($io = $ent->open("r")) {
141             while (defined($_ = $io->getline)) { print $_ }
142             $io->close;
143             }
144              
145             ### Write the (unencoded) body data:
146             if ($io = $ent->open("w")) {
147             foreach (@lines) { $io->print($_) }
148             $io->close;
149             }
150              
151             ### Delete the files for any external (on-disk) data:
152             $ent->purge;
153              
154             Muck about with the signature:
155              
156             ### Sign it (automatically removes any existing signature):
157             $top->sign(File=>"$ENV{HOME}/.signature");
158              
159             ### Remove any signature within 15 lines of the end:
160             $top->remove_sig(15);
161              
162             Muck about with the headers:
163              
164             ### Compute content-lengths for singleparts based on bodies:
165             ### (Do this right before you print!)
166             $entity->sync_headers(Length=>'COMPUTE');
167              
168             Muck about with the structure:
169              
170             ### If a 0- or 1-part multipart, collapse to a singlepart:
171             $top->make_singlepart;
172              
173             ### If a singlepart, inflate to a multipart with 1 part:
174             $top->make_multipart;
175              
176             Delete parts:
177              
178             ### Delete some parts of a multipart message:
179             my @keep = grep { keep_part($_) } $msg->parts;
180             $msg->parts(\@keep);
181              
182              
183             =head2 Output examples
184              
185             Print to filehandles:
186              
187             ### Print the entire message:
188             $top->print(\*STDOUT);
189              
190             ### Print just the header:
191             $top->print_header(\*STDOUT);
192              
193             ### Print just the (encoded) body... includes parts as well!
194             $top->print_body(\*STDOUT);
195              
196             Stringify... note that C can also be written C;
197             the methods are synonymous, and neither form will be deprecated:
198              
199             ### Stringify the entire message:
200             print $top->stringify; ### or $top->as_string
201              
202             ### Stringify just the header:
203             print $top->stringify_header; ### or $top->header_as_string
204              
205             ### Stringify just the (encoded) body... includes parts as well!
206             print $top->stringify_body; ### or $top->body_as_string
207              
208             Debug:
209              
210             ### Output debugging info:
211             $entity->dump_skeleton(\*STDERR);
212              
213              
214              
215             =head1 PUBLIC INTERFACE
216              
217             =cut
218              
219             #------------------------------
220              
221             ### Pragmas:
222 18     18   94580 use vars qw(@ISA $VERSION);
  18         33  
  18         727  
223 18     18   59 use strict;
  18         23  
  18         275  
224              
225             ### System modules:
226 18     18   51 use Carp;
  18         18  
  18         764  
227              
228             ### Other modules:
229 18     18   7359 use Mail::Internet 1.28 ();
  18         96950  
  18         552  
230 18     18   1673 use Mail::Field 1.05 ();
  18         10087  
  18         395  
231              
232             ### Kit modules:
233 18     18   973 use MIME::Tools qw(:config :msgs :utils);
  18         27  
  18         2677  
234 18     18   1625 use MIME::Head;
  18         50  
  18         330  
235 18     18   1417 use MIME::Body;
  18         24  
  18         331  
236 18     18   7158 use MIME::Decoder;
  18         34  
  18         53107  
237              
238             @ISA = qw(Mail::Internet);
239              
240              
241             #------------------------------
242             #
243             # Globals...
244             #
245             #------------------------------
246              
247             ### The package version, both in 1.23 style *and* usable by MakeMaker:
248             $VERSION = "5.508";
249              
250             ### Boundary counter:
251             my $BCount = 0;
252              
253             ### Standard "Content-" MIME fields, for scrub():
254             my $StandardFields = 'Description|Disposition|Id|Type|Transfer-Encoding';
255              
256             ### Known Mail/MIME fields... these, plus some general forms like
257             ### "x-*", are recognized by build():
258             my %KnownField = map {$_=>1}
259             qw(
260             bcc cc comments date encrypted
261             from keywords message-id mime-version organization
262             received references reply-to return-path sender
263             subject to
264             );
265              
266             ### Fallback preamble and epilogue:
267             my $DefPreamble = [ "This is a multi-part message in MIME format...\n" ];
268             my $DefEpilogue = [ ];
269              
270              
271             #==============================
272             #
273             # Utilities, private
274             #
275              
276             #------------------------------
277             #
278             # known_field FIELDNAME
279             #
280             # Is this a recognized Mail/MIME field?
281             #
282             sub known_field {
283 65     65 0 60 my $field = lc(shift);
284 65 100       240 $KnownField{$field} or ($field =~ m{^(content|resent|x)-.});
285             }
286              
287             #------------------------------
288             #
289             # make_boundary
290             #
291             # Return a unique boundary string.
292             # This is used both internally and by MIME::ParserBase, but it is NOT in
293             # the public interface! Do not use it!
294             #
295             # We generate one containing a "=_", as RFC2045 suggests:
296             # A good strategy is to choose a boundary that includes a character
297             # sequence such as "=_" which can never appear in a quoted-printable
298             # body. See the definition of multipart messages in RFC 2046.
299             #
300             sub make_boundary {
301 5     5 0 32 return "----------=_".scalar(time)."-$$-".$BCount++;
302             }
303              
304              
305              
306              
307              
308              
309             #==============================
310              
311             =head2 Construction
312              
313             =over 4
314              
315             =cut
316              
317              
318             #------------------------------
319              
320             =item new [SOURCE]
321              
322             I
323             Create a new, empty MIME entity.
324             Basically, this uses the Mail::Internet constructor...
325              
326             If SOURCE is an ARRAYREF, it is assumed to be an array of lines
327             that will be used to create both the header and an in-core body.
328              
329             Else, if SOURCE is defined, it is assumed to be a filehandle
330             from which the header and in-core body is to be read.
331              
332             B in either case, the body will not be I merely read!
333              
334             =cut
335              
336             sub new {
337 208     208 1 263 my $class = shift;
338 208         826 my $self = $class->Mail::Internet::new(@_); ### inherited
339 208         8434 $self->{ME_Parts} = []; ### no parts extracted
340 208         309 $self;
341             }
342              
343              
344             ###------------------------------
345              
346             =item add_part ENTITY, [OFFSET]
347              
348             I
349             Assuming we are a multipart message, add a body part (a MIME::Entity)
350             to the array of body parts. Returns the part that was just added.
351              
352             If OFFSET is positive, the new part is added at that offset from the
353             beginning of the array of parts. If it is negative, it counts from
354             the end of the array. (An INDEX of -1 will place the new part at the
355             very end of the array, -2 will place it as the penultimate item in the
356             array, etc.) If OFFSET is not given, the new part is added to the end
357             of the array.
358             I
359              
360             B in general, you only want to attach parts to entities
361             with a content-type of C).
362              
363             =cut
364              
365             sub add_part {
366 123     123 1 178 my ($self, $part, $index) = @_;
367 123 50       239 defined($index) or $index = -1;
368              
369             ### Make $index count from the end if negative:
370 123 50       219 $index = $#{$self->{ME_Parts}} + 2 + $index if ($index < 0);
  123         213  
371 123         100 splice(@{$self->{ME_Parts}}, $index, 0, $part);
  123         196  
372 123         167 $part;
373             }
374              
375             #------------------------------
376              
377             =item attach PARAMHASH
378              
379             I
380             The real quick-and-easy way to create multipart messages.
381             The PARAMHASH is used to C a new entity; this method is
382             basically equivalent to:
383              
384             $entity->add_part(ref($entity)->build(PARAMHASH, Top=>0));
385              
386             B normally, you attach to multipart entities; however, if you
387             attach something to a singlepart (like attaching a GIF to a text
388             message), the singlepart will be coerced into a multipart automatically.
389              
390             =cut
391              
392             sub attach {
393 5     5 1 16 my $self = shift;
394 5         12 $self->make_multipart;
395 5         19 $self->add_part(ref($self)->build(@_, Top=>0));
396             }
397              
398             #------------------------------
399              
400             =item build PARAMHASH
401              
402             I
403             A quick-and-easy catch-all way to create an entity. Use it like this
404             to build a "normal" single-part entity:
405              
406             $ent = MIME::Entity->build(Type => "image/gif",
407             Encoding => "base64",
408             Path => "/path/to/xyz12345.gif",
409             Filename => "saveme.gif",
410             Disposition => "attachment");
411              
412             And like this to build a "multipart" entity:
413              
414             $ent = MIME::Entity->build(Type => "multipart/mixed",
415             Boundary => "---1234567");
416              
417             A minimal MIME header will be created. If you want to add or modify
418             any header fields afterwards, you can of course do so via the underlying
419             head object... but hey, there's now a prettier syntax!
420              
421             $ent = MIME::Entity->build(Type =>"multipart/mixed",
422             From => $myaddr,
423             Subject => "Hi!",
424             'X-Certified' => ['SINED',
425             'SEELED',
426             'DELIVERED']);
427              
428             Normally, an C header field is output which contains this
429             toolkit's name and version (plus this module's RCS version).
430             This will allow any bad MIME we generate to be traced back to us.
431             You can of course overwrite that header with your own:
432              
433             $ent = MIME::Entity->build(Type => "multipart/mixed",
434             'X-Mailer' => "myprog 1.1");
435              
436             Or remove it entirely:
437              
438             $ent = MIME::Entity->build(Type => "multipart/mixed",
439             'X-Mailer' => undef);
440              
441             OK, enough hype. The parameters are:
442              
443             =over 4
444              
445             =item (FIELDNAME)
446              
447             Any field you want placed in the message header, taken from the
448             standard list of header fields (you don't need to worry about case):
449              
450             Bcc Encrypted Received Sender
451             Cc From References Subject
452             Comments Keywords Reply-To To
453             Content-* Message-ID Resent-* X-*
454             Date MIME-Version Return-Path
455             Organization
456              
457             To give experienced users some veto power, these fields will be set
458             I the ones I set... so be careful: I
459             (like C) unless you know what you're doing!
460              
461             To specify a fieldname that's I in the above list, even one that's
462             identical to an option below, just give it with a trailing C<":">,
463             like C<"My-field:">. When in doubt, that I signals a mail
464             field (and it sort of looks like one too).
465              
466             =item Boundary
467              
468             I
469             The boundary string. As per RFC-2046, it must consist only
470             of the characters C<[0-9a-zA-Z'()+_,-./:=?]> and space (you'll be
471             warned, and your boundary will be ignored, if this is not the case).
472             If you omit this, a random string will be chosen... which is probably
473             safer.
474              
475             =item Charset
476              
477             I
478             The character set.
479              
480             =item Data
481              
482             I
483             An alternative to Path (q.v.): the actual data, either as a scalar
484             or an array reference (whose elements are joined together to make
485             the actual scalar). The body is opened on the data using
486             MIME::Body::InCore.
487              
488             =item Description
489              
490             I
491             The text of the content-description.
492             If you don't specify it, the field is not put in the header.
493              
494             =item Disposition
495              
496             I
497             The basic content-disposition (C<"attachment"> or C<"inline">).
498             If you don't specify it, it defaults to "inline" for backwards
499             compatibility. I
500              
501             =item Encoding
502              
503             I
504             The content-transfer-encoding.
505             If you don't specify it, a reasonable default is put in.
506             You can also give the special value '-SUGGEST', to have it chosen for
507             you in a heavy-duty fashion which scans the data itself.
508              
509             =item Filename
510              
511             I
512             The recommended filename. Overrides any name extracted from C.
513             The information is stored both the deprecated (content-type) and
514             preferred (content-disposition) locations. If you explicitly want to
515             I a recommended filename (even when Path is used), supply this
516             as empty or undef.
517              
518             =item Id
519              
520             I
521             Set the content-id.
522              
523             =item Path
524              
525             I
526             The path to the file to attach. The body is opened on that file
527             using MIME::Body::File.
528              
529             =item Top
530              
531             I
532             Is this a top-level entity? If so, it must sport a MIME-Version.
533             The default is true. (NB: look at how C uses it.)
534              
535             =item Type
536              
537             I
538             The basic content-type (C<"text/plain">, etc.).
539             If you don't specify it, it defaults to C<"text/plain">
540             as per RFC 2045. I
541              
542             =back
543              
544             =cut
545              
546             sub build {
547 29     29 1 9410 my ($self, @paramlist) = @_;
548 29         78 my %params = @paramlist;
549 29         29 my ($field, $filename, $boundary);
550              
551             ### Create a new entity, if needed:
552 29 50       90 ref($self) or $self = $self->new;
553              
554              
555             ### GET INFO...
556              
557             ### Get sundry field:
558 29   100     88 my $type = $params{Type} || 'text/plain';
559 29         36 my $charset = $params{Charset};
560 29         50 my $is_multipart = ($type =~ m{^multipart/}i);
561 29   100     79 my $encoding = $params{Encoding} || '';
562 29         28 my $desc = $params{Description};
563 29 100       51 my $top = exists($params{Top}) ? $params{Top} : 1;
564 29   100     87 my $disposition = $params{Disposition} || 'inline';
565 29         25 my $id = $params{Id};
566              
567             ### Get recommended filename, allowing explicit no-value value:
568 29   100     135 my ($path_fname) = (($params{Path}||'') =~ m{([^/]+)\Z});
569 29 100       44 $filename = (exists($params{Filename}) ? $params{Filename} : $path_fname);
570 29 50 66     96 $filename = undef if (defined($filename) and $filename eq '');
571              
572             ### Type-check sanity:
573 29 100       67 if ($type =~ m{^(multipart/|message/(rfc822|partial|external-body|delivery-status|disposition-notification|feedback-report)$)}i) {
574 5 100       322 ($encoding =~ /^(|7bit|8bit|binary|-suggest)$/i)
575             or croak "can't have encoding $encoding for message type $type!";
576             }
577              
578             ### Multipart or not? Do sanity check and fixup:
579 27 100       38 if ($is_multipart) { ### multipart...
580              
581             ### Get any supplied boundary, and check it:
582 3 50       9 if (defined($boundary = $params{Boundary})) { ### they gave us one...
583 0 0       0 if ($boundary eq '') {
    0          
584 0         0 whine "empty string not a legal boundary: I'm ignoring it";
585 0         0 $boundary = undef;
586             }
587             elsif ($boundary =~ m{[^0-9a-zA-Z_\'\(\)\+\,\.\/\:\=\?\- ]}) {
588 0         0 whine "boundary ignored: illegal characters ($boundary)";
589 0         0 $boundary = undef;
590             }
591             }
592              
593             ### If we have to roll our own boundary, do so:
594 3 50       24 defined($boundary) or $boundary = make_boundary();
595             }
596             else { ### single part...
597             ### Create body:
598 24 100       48 if ($params{Path}) {
    50          
599 14         64 $self->bodyhandle(new MIME::Body::File $params{Path});
600             }
601             elsif (defined($params{Data})) {
602 10         104 $self->bodyhandle(new MIME::Body::InCore $params{Data});
603             }
604             else {
605 0         0 die "can't build entity: no body, and not multipart\n";
606             }
607              
608             ### Check whether we need to binmode(): [Steve Kilbane]
609 24 100       57 $self->bodyhandle->binmode(1) unless textual_type($type);
610             }
611              
612              
613             ### MAKE HEAD...
614              
615             ### Create head:
616 27         65 my $head = new MIME::Head;
617 27         494 $self->head($head);
618 27         44 $head->modify(1);
619              
620             ### Add content-type field:
621 27         169 $field = new Mail::Field 'Content_type'; ### not a typo :-(
622 27         88 $field->type($type);
623 27 100       49 $field->charset($charset) if $charset;
624 27 100       73 $field->name($filename) if defined($filename);
625 27 100       55 $field->boundary($boundary) if defined($boundary);
626 27         57 $head->replace('Content-type', $field->stringify);
627              
628             ### Now that both body and content-type are available, we can suggest
629             ### content-transfer-encoding (if desired);
630 27 100       3246 if (!$encoding) {
    100          
631 22         59 $encoding = $self->suggest_encoding_lite;
632             }
633             elsif (lc($encoding) eq '-suggest') {
634 3         9 $encoding = $self->suggest_encoding;
635             }
636              
637             ### Add content-disposition field (if not multipart):
638 27 100       62 unless ($is_multipart) {
639 24         67 $field = new Mail::Field 'Content_disposition'; ### not a typo :-(
640 24         95 $field->type($disposition);
641 24 100       68 $field->filename($filename) if defined($filename);
642 24         53 $head->replace('Content-disposition', $field->stringify);
643             }
644              
645             ### Add other MIME fields:
646 27 50       2315 $head->replace('Content-transfer-encoding', $encoding) if $encoding;
647 27 50       2360 $head->replace('Content-description', $desc) if $desc;
648              
649             # Content-Id value should be surrounded by < >, but versions before 5.428
650             # did not do this. So, we check, and add if the caller has not done so
651             # already.
652 27 100       43 if( defined $id ) {
653 2 100       6 if( $id !~ /^<.*>$/ ) {
654 1         4 $id = "<$id>";
655             }
656 2         4 $head->replace('Content-id', $id);
657             }
658 27 100       246 $head->replace('MIME-Version', '1.0') if $top;
659              
660             ### Add the X-Mailer field, if top level (use default value if not given):
661 27 100       1922 $top and $head->replace('X-Mailer',
662             "MIME-tools ".(MIME::Tools->version).
663             " (Entity " .($VERSION).")");
664              
665             ### Add remaining user-specified fields, if any:
666 27         1853 while (@paramlist) {
667 67         513 my ($tag, $value) = (shift @paramlist, shift @paramlist);
668              
669             ### Get fieldname, if that's what it is:
670 67 100       205 if ($tag =~ /^-(.*)/s) { $tag = lc($1) } ### old style, b.c.
  2 50       6  
    100          
671 0         0 elsif ($tag =~ /(.*):$/s ) { $tag = lc($1) } ### new style
672 6         6 elsif (known_field(lc($tag))) { 1 } ### known field
673 59         123 else { next; } ### not a field
674              
675             ### Clear head, get list of values, and add them:
676 8         30 $head->delete($tag);
677 8 50       117 foreach $value (ref($value) ? @$value : ($value)) {
678 8 50 33     34 (defined($value) && ($value ne '')) or next;
679 8         27 $head->add($tag, $value);
680             }
681             }
682              
683             ### Done!
684 27         350 $self;
685             }
686              
687             #------------------------------
688              
689             =item dup
690              
691             I
692             Duplicate the entity. Does a deep, recursive copy, I
693             external data in bodyhandles is I copied to new files!
694             Changing the data in one entity's data file, or purging that entity,
695             I affect its duplicate. Entities with in-core data probably need
696             not worry.
697              
698             =cut
699              
700             sub dup {
701 7     7 1 10 my $self = shift;
702 7         7 local($_);
703              
704             ### Self (this will also dup the header):
705 7         32 my $dup = bless $self->SUPER::dup(), ref($self);
706              
707             ### Any simple inst vars:
708 7 50       762 foreach (keys %$self) {$dup->{$_} = $self->{$_} unless ref($self->{$_})};
  20         39  
709              
710             ### Bodyhandle:
711 7 100       19 $dup->bodyhandle($self->bodyhandle ? $self->bodyhandle->dup : undef);
712              
713             ### Preamble and epilogue:
714 7         13 foreach (qw(ME_Preamble ME_Epilogue)) {
715 14 100       25 $dup->{$_} = [@{$self->{$_}}] if $self->{$_};
  2         5  
716             }
717              
718             ### Parts:
719 7         11 $dup->{ME_Parts} = [];
720 7         7 foreach (@{$self->{ME_Parts}}) { push @{$dup->{ME_Parts}}, $_->dup }
  7         15  
  4         4  
  4         8  
721              
722             ### Done!
723 7         13 $dup;
724             }
725              
726             =back
727              
728             =cut
729              
730              
731              
732              
733              
734             #==============================
735              
736             =head2 Access
737              
738             =over 4
739              
740             =cut
741              
742              
743             #------------------------------
744              
745             =item body [VALUE]
746              
747             I
748             Get the I (transport-ready) body, as an array of lines.
749             Returns an array reference. Each array entry is a newline-terminated
750             line.
751              
752             This is a read-only data structure: changing its contents will have
753             no effect. Its contents are identical to what is printed by
754             L.
755              
756             Provided for compatibility with Mail::Internet, so that methods
757             like C will work. Note however that if VALUE is given,
758             a fatal exception is thrown, since you cannot use this method to
759             I the lines of the encoded message.
760              
761             If you want the raw (unencoded) body data, use the L
762             method to get and use a MIME::Body. The content-type of the entity
763             will tell you whether that body is best read as text (via getline())
764             or raw data (via read()).
765              
766             =cut
767              
768             sub body {
769 3     3 1 2755 my ($self, $value) = @_;
770 3 50       14 if (@_ > 1) { ### setting body line(s)...
771 0         0 croak "you cannot use body() to set the encoded contents\n";
772             } else {
773 3         6 my $output = '';
774 3 50       44 my $fh = IO::File->new(\$output, '>:') or croak("Cannot open in-memory file: $!");
775 3         901 $self->print_body($fh);
776 3         4 close($fh);
777 3         19 my @ary = split(/\n/, $output);
778             # Each line needs the terminating newline
779 3         6 @ary = map { "$_\n" } @ary;
  27         38  
780              
781 3         21 return \@ary;
782             }
783             }
784              
785             #------------------------------
786              
787             =item bodyhandle [VALUE]
788              
789             I
790             Get or set an abstract object representing the body of the message.
791             The body holds the decoded message data.
792              
793             B
794             An entity will have either a body or parts: not both.
795             This method will I return an object if this entity can
796             have a body; otherwise, it will return undefined.
797             Whether-or-not a given entity can have a body is determined by
798             (1) its content type, and (2) whether-or-not the parser was told to
799             extract nested messages:
800              
801             Type: | Extract nested? | bodyhandle() | parts()
802             -----------------------------------------------------------------------
803             multipart/* | - | undef | 0 or more MIME::Entity
804             message/* | true | undef | 0 or 1 MIME::Entity
805             message/* | false | MIME::Body | empty list
806             (other) | - | MIME::Body | empty list
807              
808             If C I given, the current bodyhandle is returned,
809             or undef if the entity cannot have a body.
810              
811             If C I given, the bodyhandle is set to the new value,
812             and the previous value is returned.
813              
814             See L for more info.
815              
816             =cut
817              
818             sub bodyhandle {
819 605     605 1 8146 my ($self, $newvalue) = @_;
820 605         566 my $value = $self->{ME_Bodyhandle};
821 605 100       961 $self->{ME_Bodyhandle} = $newvalue if (@_ > 1);
822 605         1167 $value;
823             }
824              
825             #------------------------------
826              
827             =item effective_type [MIMETYPE]
828              
829             I
830             Set/get the I MIME type of this entity. This is I
831             identical to the actual (or defaulted) MIME type, but in some cases
832             it differs. For example, from RFC-2045:
833              
834             Any entity with an unrecognized Content-Transfer-Encoding must be
835             treated as if it has a Content-Type of "application/octet-stream",
836             regardless of what the Content-Type header field actually says.
837              
838             Why? because if we can't decode the message, then we have to take
839             the bytes as-is, in their (unrecognized) encoded form. So the
840             message ceases to be a "text/foobar" and becomes a bunch of undecipherable
841             bytes -- in other words, an "application/octet-stream".
842              
843             Such an entity, if parsed, would have its effective_type() set to
844             C<"application/octet_stream">, although the mime_type() and the contents
845             of the header would remain the same.
846              
847             If there is no effective type, the method just returns what
848             mime_type() would.
849              
850             B the effective type is "sticky"; once set, that effective_type()
851             will always be returned even if the conditions that necessitated setting
852             the effective type become no longer true.
853              
854             =cut
855              
856             sub effective_type {
857 284     284 1 233 my $self = shift;
858 284 50       467 $self->{ME_EffType} = shift if @_;
859 284 50       683 return ($self->{ME_EffType} ? lc($self->{ME_EffType}) : $self->mime_type);
860             }
861              
862              
863             #------------------------------
864              
865             =item epilogue [LINES]
866              
867             I
868             Get/set the text of the epilogue, as an array of newline-terminated LINES.
869             Returns a reference to the array of lines, or undef if no epilogue exists.
870              
871             If there is a epilogue, it is output when printing this entity; otherwise,
872             a default epilogue is used. Setting the epilogue to undef (not []!) causes
873             it to fallback to the default.
874              
875             =cut
876              
877             sub epilogue {
878 51     51 1 80 my ($self, $lines) = @_;
879 51 100       123 $self->{ME_Epilogue} = $lines if @_ > 1;
880 51         110 $self->{ME_Epilogue};
881             }
882              
883             #------------------------------
884              
885             =item head [VALUE]
886              
887             I
888             Get/set the head.
889              
890             If there is no VALUE given, returns the current head. If none
891             exists, an empty instance of MIME::Head is created, set, and returned.
892              
893             B This is a patch over a problem in Mail::Internet, which doesn't
894             provide a method for setting the head to some given object.
895              
896             =cut
897              
898             sub head {
899 1755     1755 1 1044022 my ($self, $value) = @_;
900 1755 100       2526 (@_ > 1) and $self->{'mail_inet_head'} = $value;
901 1755   66     5516 $self->{'mail_inet_head'} ||= new MIME::Head; ### KLUDGE!
902             }
903              
904             #------------------------------
905              
906             =item is_multipart
907              
908             I
909             Does this entity's effective MIME type indicate that it's a multipart entity?
910             Returns undef (false) if the answer couldn't be determined, 0 (false)
911             if it was determined to be false, and true otherwise.
912             Note that this says nothing about whether or not parts were extracted.
913              
914             NOTE: we switched to effective_type so that multiparts with
915             bad or missing boundaries could be coerced to an effective type
916             of C.
917              
918              
919             =cut
920              
921             sub is_multipart {
922 28     28 1 85 my $self = shift;
923 28 50       40 $self->head or return undef; ### no head, so no MIME type!
924 28         51 my ($type, $subtype) = split('/', $self->effective_type);
925 28 100       115 (($type eq 'multipart') ? 1 : 0);
926             }
927              
928             #------------------------------
929              
930             =item mime_type
931              
932             I
933             A purely-for-convenience method. This simply relays the request to the
934             associated MIME::Head object.
935             If there is no head, returns undef in a scalar context and
936             the empty array in a list context.
937              
938             B consider using effective_type() instead,
939             especially if you obtained the entity from a MIME::Parser.
940              
941             =cut
942              
943             sub mime_type {
944 363     363 1 824 my $self = shift;
945 363 0       503 $self->head or return (wantarray ? () : undef);
    50          
946 363         510 $self->head->mime_type;
947             }
948              
949             #------------------------------
950              
951             =item open READWRITE
952              
953             I
954             A purely-for-convenience method. This simply relays the request to the
955             associated MIME::Body object (see MIME::Body::open()).
956             READWRITE is either 'r' (open for read) or 'w' (open for write).
957              
958             If there is no body, returns false.
959              
960             =cut
961              
962             sub open {
963 68     68 1 50 my $self = shift;
964 68 50       95 $self->bodyhandle and $self->bodyhandle->open(@_);
965             }
966              
967             #------------------------------
968              
969             =item parts
970              
971             =item parts INDEX
972              
973             =item parts ARRAYREF
974              
975             I
976             Return the MIME::Entity objects which are the sub parts of this
977             entity (if any).
978              
979             I returns the array of all sub parts,
980             returning the empty array if there are none (e.g., if this is a single
981             part message, or a degenerate multipart). In a scalar context, this
982             returns you the number of parts.
983              
984             I return the INDEXed part,
985             or undef if it doesn't exist.
986              
987             I then this method I
988             the parts to a copy of that array, and returns the parts. This can
989             be used to delete parts, as follows:
990              
991             ### Delete some parts of a multipart message:
992             $msg->parts([ grep { keep_part($_) } $msg->parts ]);
993              
994              
995             B for multipart messages, the preamble and epilogue are I
996             considered parts. If you need them, use the C and C
997             methods.
998              
999             B there are ways of parsing with a MIME::Parser which cause
1000             certain message parts (such as those of type C)
1001             to be "reparsed" into pseudo-multipart entities. You should read the
1002             documentation for those options carefully: it I possible for
1003             a diddled entity to not be multipart, but still have parts attached to it!
1004              
1005             See L for a discussion of parts vs. bodies.
1006              
1007             =cut
1008              
1009             sub parts {
1010 211     211 1 3657 my $self = shift;
1011 211 100       354 ref($_[0]) and return @{$self->{ME_Parts} = [@{$_[0]}]}; ### set the parts
  5         8  
  5         20  
1012 206 100       449 (@_ ? $self->{ME_Parts}[$_[0]] : @{$self->{ME_Parts}});
  100         213  
1013             }
1014              
1015             #------------------------------
1016              
1017             =item parts_DFS
1018              
1019             I
1020             Return the list of all MIME::Entity objects included in the entity,
1021             starting with the entity itself, in depth-first-search order.
1022             If the entity has no parts, it alone will be returned.
1023              
1024             I
1025              
1026             =cut
1027              
1028             sub parts_DFS {
1029 0     0 1 0 my $self = shift;
1030 0         0 return ($self, map { $_->parts_DFS } $self->parts);
  0         0  
1031             }
1032              
1033             #------------------------------
1034              
1035             =item preamble [LINES]
1036              
1037             I
1038             Get/set the text of the preamble, as an array of newline-terminated LINES.
1039             Returns a reference to the array of lines, or undef if no preamble exists
1040             (e.g., if this is a single-part entity).
1041              
1042             If there is a preamble, it is output when printing this entity; otherwise,
1043             a default preamble is used. Setting the preamble to undef (not []!) causes
1044             it to fallback to the default.
1045              
1046             =cut
1047              
1048             sub preamble {
1049 58     58 1 1731 my ($self, $lines) = @_;
1050 58 100       165 $self->{ME_Preamble} = $lines if @_ > 1;
1051 58         99 $self->{ME_Preamble};
1052             }
1053              
1054              
1055              
1056              
1057              
1058             =back
1059              
1060             =cut
1061              
1062              
1063              
1064              
1065             #==============================
1066              
1067             =head2 Manipulation
1068              
1069             =over 4
1070              
1071             =cut
1072              
1073             #------------------------------
1074              
1075             =item make_multipart [SUBTYPE], OPTSHASH...
1076              
1077             I
1078             Force the entity to be a multipart, if it isn't already.
1079             We do this by replacing the original [singlepart] entity with a new
1080             multipart that has the same non-MIME headers ("From", "Subject", etc.),
1081             but all-new MIME headers ("Content-type", etc.). We then create
1082             a copy of the original singlepart, I the non-MIME headers
1083             from that, and make it a part of the new multipart. So this:
1084              
1085             From: me
1086             To: you
1087             Content-type: text/plain
1088             Content-length: 12
1089              
1090             Hello there!
1091              
1092             Becomes something like this:
1093              
1094             From: me
1095             To: you
1096             Content-type: multipart/mixed; boundary="----abc----"
1097              
1098             ------abc----
1099             Content-type: text/plain
1100             Content-length: 12
1101              
1102             Hello there!
1103             ------abc------
1104              
1105             The actual type of the new top-level multipart will be "multipart/SUBTYPE"
1106             (default SUBTYPE is "mixed").
1107              
1108             Returns 'DONE' if we really did inflate a singlepart to a multipart.
1109             Returns 'ALREADY' (and does nothing) if entity is I multipart
1110             and Force was not chosen.
1111              
1112             If OPTSHASH contains Force=>1, then we I bump the top-level's
1113             content and content-headers down to a subpart of this entity, even if
1114             this entity is already a multipart. This is apparently of use to
1115             people who are tweaking messages after parsing them.
1116              
1117             =cut
1118              
1119             sub make_multipart {
1120 7     7 1 10 my ($self, $subtype, %opts) = @_;
1121 7         11 my $tag;
1122 7   50     29 $subtype ||= 'mixed';
1123 7         11 my $force = $opts{Force};
1124              
1125             ### Trap for simple case: already a multipart?
1126 7 100 66     18 return 'ALREADY' if ($self->is_multipart and !$force);
1127              
1128             ### Rip out our guts, and spew them into our future part:
1129 2         8 my $part = bless {%$self}, ref($self); ### part is a shallow copy
1130 2         6 %$self = (); ### lobotomize ourselves!
1131 2         5 $self->head($part->head->dup); ### dup the header
1132              
1133             ### Remove content headers from top-level, and set it up as a multipart:
1134 2         6 foreach $tag (grep {/^content-/i} $self->head->tags) {
  3         9  
1135 0         0 $self->head->delete($tag);
1136             }
1137 2         10 $self->head->mime_attr('Content-type' => "multipart/$subtype");
1138 2         31 $self->head->mime_attr('Content-type.boundary' => make_boundary());
1139              
1140             ### Remove NON-content headers from the part:
1141 2         6 foreach $tag (grep {!/^content-/i} $part->head->tags) {
  3         8  
1142 3         100 $part->head->delete($tag);
1143             }
1144              
1145             ### Add the [sole] part:
1146 2         35 $self->{ME_Parts} = [];
1147 2         6 $self->add_part($part);
1148 2         4 'DONE';
1149             }
1150              
1151             #------------------------------
1152              
1153             =item make_singlepart
1154              
1155             I
1156             If the entity is a multipart message with one part, this tries hard to
1157             rewrite it as a singlepart, by replacing the content (and content headers)
1158             of the top level with those of the part. Also crunches 0-part multiparts
1159             into singleparts.
1160              
1161             Returns 'DONE' if we really did collapse a multipart to a singlepart.
1162             Returns 'ALREADY' (and does nothing) if entity is already a singlepart.
1163             Returns '0' (and does nothing) if it can't be made into a singlepart.
1164              
1165             =cut
1166              
1167             sub make_singlepart {
1168 1     1 1 9 my $self = shift;
1169              
1170             ### Trap for simple cases:
1171 1 50       5 return 'ALREADY' if !$self->is_multipart; ### already a singlepart?
1172 1 50       4 return '0' if ($self->parts > 1); ### can this even be done?
1173              
1174             # Get rid of all our existing content info
1175 1         2 my $tag;
1176 1         5 foreach $tag (grep {/^content-/i} $self->head->tags) {
  13         35  
1177 1         3 $self->head->delete($tag);
1178             }
1179              
1180 1 50       172 if ($self->parts == 1) { ### one part
1181 0         0 my $part = $self->parts(0);
1182              
1183             ### Populate ourselves with any content info from the part:
1184 0         0 foreach $tag (grep {/^content-/i} $part->head->tags) {
  0         0  
1185 0         0 foreach ($part->head->get($tag)) { $self->head->add($tag, $_) }
  0         0  
1186             }
1187              
1188             ### Save reconstructed header, replace our guts, and restore header:
1189 0         0 my $new_head = $self->head;
1190 0         0 %$self = %$part; ### shallow copy is ok!
1191 0         0 $self->head($new_head);
1192              
1193             ### One more thing: the part *may* have been a multi with 0 or 1 parts!
1194 0 0       0 return $self->make_singlepart(@_) if $self->is_multipart;
1195             }
1196             else { ### no parts!
1197 1         5 $self->head->mime_attr('Content-type'=>'text/plain'); ### simple
1198             }
1199 1         9 'DONE';
1200             }
1201              
1202             #------------------------------
1203              
1204             =item purge
1205              
1206             I
1207             Recursively purge (e.g., unlink) all external (e.g., on-disk) body parts
1208             in this message. See MIME::Body::purge() for details.
1209              
1210             B this does I delete the directories that those body parts
1211             are contained in; only the actual message data files are deleted.
1212             This is because some parsers may be customized to create intermediate
1213             directories while others are not, and it's impossible for this class
1214             to know what directories are safe to remove. Only your application
1215             program truly knows that.
1216              
1217             B one good way is to
1218             use C, and then do this before parsing
1219             your next message:
1220              
1221             $parser->filer->purge();
1222              
1223             I wouldn't attempt to read those body files after you do this, for
1224             obvious reasons. As of MIME-tools 4.x, each body's path I undefined
1225             after this operation. I warned you I might do this; truly I did.
1226              
1227             I
1228              
1229             =cut
1230              
1231             sub purge {
1232 4     4 1 6 my $self = shift;
1233 4 100       6 $self->bodyhandle and $self->bodyhandle->purge; ### purge me
1234 4         6 foreach ($self->parts) { $_->purge } ### recurse
  3         6  
1235 4         6 1;
1236             }
1237              
1238             #------------------------------
1239             #
1240             # _do_remove_sig
1241             #
1242             # Private. Remove a signature within NLINES lines from the end of BODY.
1243             # The signature must be flagged by a line containing only "-- ".
1244              
1245             sub _do_remove_sig {
1246 4     4   5 my ($body, $nlines) = @_;
1247 4   100     13 $nlines ||= 10;
1248 4         4 my $i = 0;
1249              
1250 4   50     8 my $line = int(@$body) || return;
1251 4   66     15 while ($i++ < $nlines and $line--) {
1252 25 100       75 if ($body->[$line] =~ /\A--[ \040][\r\n]+\Z/) {
1253 2         3 $#{$body} = $line-1;
  2         7  
1254 2         3 return;
1255             }
1256             }
1257             }
1258              
1259             #------------------------------
1260              
1261             =item remove_sig [NLINES]
1262              
1263             I
1264             Attempts to remove a user's signature from the body of a message.
1265              
1266             It does this by looking for a line matching C within the last
1267             C of the message. If found then that line and all lines after
1268             it will be removed. If C is not given, a default value of 10
1269             will be used. This would be of most use in auto-reply scripts.
1270              
1271             For MIME entity, this method is reasonably cautious: it will only
1272             attempt to un-sign a message with a content-type of C.
1273              
1274             If you send remove_sig() to a multipart entity, it will relay it to
1275             the first part (the others usually being the "attachments").
1276              
1277             B currently slurps the whole message-part into core as an
1278             array of lines, so you probably don't want to use this on extremely
1279             long messages.
1280              
1281             Returns truth on success, false on error.
1282              
1283             =cut
1284              
1285             sub remove_sig {
1286 3     3 1 633 my $self = shift;
1287 3         3 my $nlines = shift;
1288              
1289             # If multipart, we only attempt to remove the sig from the first
1290             # part. This is usually a good assumption for multipart/mixed, but
1291             # may not always be correct. It is also possibly incorrect on
1292             # multipart/alternative (both may have sigs).
1293 3 100       8 if( $self->is_multipart ) {
1294 2         6 my $first_part = $self->parts(0);
1295 2 100       5 if( $first_part ) {
1296 1         4 return $first_part->remove_sig(@_);
1297             }
1298 1         4 return undef;
1299             }
1300              
1301             ### Refuse non-textual unless forced:
1302 1 50       4 textual_type($self->head->mime_type)
1303             or return error "I won't un-sign a non-text message unless I'm forced";
1304              
1305             ### Get body data, as an array of newline-terminated lines:
1306 1 50       4 $self->bodyhandle or return undef;
1307 1         3 my @body = $self->bodyhandle->as_lines;
1308              
1309             ### Nuke sig:
1310 1         3 _do_remove_sig(\@body, $nlines);
1311              
1312             ### Output data back into body:
1313 1         3 my $io = $self->bodyhandle->open("w");
1314 1         3 foreach (@body) { $io->print($_) }; ### body data
  6         27  
1315 1         4 $io->close;
1316              
1317             ### Done!
1318 1         25 1;
1319             }
1320              
1321             #------------------------------
1322              
1323             =item sign PARAMHASH
1324              
1325             I
1326             Append a signature to the message. The params are:
1327              
1328             =over 4
1329              
1330             =item Attach
1331              
1332             Instead of appending the text, add it to the message as an attachment.
1333             The disposition will be C, and the description will indicate
1334             that it is a signature. The default behavior is to append the signature
1335             to the text of the message (or the text of its first part if multipart).
1336             I
1337              
1338             =item File
1339              
1340             Use the contents of this file as the signature.
1341             Fatal error if it can't be read.
1342             I
1343              
1344             =item Force
1345              
1346             Sign it even if the content-type isn't C. Useful for
1347             non-standard types like C, but be careful!
1348             I
1349              
1350             =item Remove
1351              
1352             Normally, we attempt to strip out any existing signature.
1353             If true, this gives us the NLINES parameter of the remove_sig call.
1354             If zero but defined, tells us I to remove any existing signature.
1355             If undefined, removal is done with the default of 10 lines.
1356             I
1357              
1358             =item Signature
1359              
1360             Use this text as the signature. You can supply it as either
1361             a scalar, or as a ref to an array of newline-terminated scalars.
1362             I
1363              
1364             =back
1365              
1366             For MIME messages, this method is reasonably cautious: it will only
1367             attempt to sign a message with a content-type of C, unless
1368             C is specified.
1369              
1370             If you send this message to a multipart entity, it will relay it to
1371             the first part (the others usually being the "attachments").
1372              
1373             B currently slurps the whole message-part into core as an
1374             array of lines, so you probably don't want to use this on extremely
1375             long messages.
1376              
1377             Returns true on success, false otherwise.
1378              
1379             =cut
1380              
1381             sub sign {
1382 6     6 1 643 my $self = shift;
1383 6         12 my %params = @_;
1384 6         4 my $io;
1385              
1386             ### If multipart and not attaching, try to sign our first part:
1387 6 100 66     12 if ($self->is_multipart and !$params{Attach}) {
1388 3         5 return $self->parts(0)->sign(@_);
1389             }
1390              
1391             ### Get signature:
1392 3         4 my $sig;
1393 3 50       9 if (defined($sig = $params{Signature})) { ### scalar or array
    50          
1394 0 0       0 $sig = (ref($sig) ? join('', @$sig) : $sig);
1395             }
1396             elsif ($params{File}) { ### file contents
1397 3 50       13 my $fh = IO::File->new( $params{File} ) or croak "can't open $params{File}: $!";
1398 3         204 $sig = join('', $fh->getlines);
1399 3 50       124 $fh->close or croak "can't close $params{File}: $!";
1400             }
1401             else {
1402 0         0 croak "no signature given!";
1403             }
1404              
1405             ### Add signature to message as appropriate:
1406 3 50       49 if ($params{Attach}) { ### Attach .sig as new part...
1407 0         0 return $self->attach(Type => 'text/plain',
1408             Description => 'Signature',
1409             Disposition => 'inline',
1410             Encoding => '-SUGGEST',
1411             Data => $sig);
1412             }
1413             else { ### Add text of .sig to body data...
1414              
1415             ### Refuse non-textual unless forced:
1416 3 0 33     7 ($self->head->mime_type =~ m{text/}i or $params{Force}) or
1417             return error "I won't sign a non-text message unless I'm forced";
1418              
1419             ### Get body data, as an array of newline-terminated lines:
1420 3 50       7 $self->bodyhandle or return undef;
1421 3         5 my @body = $self->bodyhandle->as_lines;
1422              
1423             ### Nuke any existing sig?
1424 3 50 66     12 if (!defined($params{Remove}) || ($params{Remove} > 0)) {
1425 3         10 _do_remove_sig(\@body, $params{Remove});
1426             }
1427              
1428             ### Output data back into body, followed by signature:
1429 3         3 my $line;
1430 3 50       7 $io = $self->open("w") or croak("open: $!");
1431 3         6 foreach $line (@body) { $io->print($line) }; ### body data
  18         61  
1432 3 50 50     21 (($body[-1]||'') =~ /\n\Z/) or $io->print("\n"); ### ensure final \n
1433 3         11 $io->print("-- \n$sig"); ### separator + sig
1434 3 50       11 $io->close or croak("close: $!");
1435 3         82 return 1; ### done!
1436             }
1437             }
1438              
1439             #------------------------------
1440              
1441             =item suggest_encoding
1442              
1443             I
1444             Based on the effective content type, return a good suggested encoding.
1445              
1446             C and C types have their bodies scanned line-by-line
1447             for 8-bit characters and long lines; lack of either means that the
1448             message is 7bit-ok. Other types are chosen independent of their body:
1449              
1450             Major type: 7bit ok? Suggested encoding:
1451             -----------------------------------------------------------
1452             text yes 7bit
1453             text no quoted-printable
1454             message yes 7bit
1455             message no binary
1456             multipart * binary (in case some parts are bad)
1457             image, etc... * base64
1458              
1459             =cut
1460              
1461             ### TO DO: resolve encodings of nested entities (possibly in sync_headers).
1462              
1463             sub suggest_encoding {
1464 3     3 1 3 my $self = shift;
1465              
1466 3         6 my ($type) = split '/', $self->effective_type;
1467 3 100 66     12 if (($type eq 'text') || ($type eq 'message')) { ### scan message body
1468 2 0       4 $self->bodyhandle || return ($self->parts ? 'binary' : '7bit');
    50          
1469 2         3 my ($IO, $unclean);
1470 2 50       3 if ($IO = $self->bodyhandle->open("r")) {
1471             ### Scan message for 7bit-cleanliness
1472 2         3 local $_;
1473 2         48 while (defined($_ = $IO->getline)) {
1474 6 100 66     224 last if ($unclean = ((length($_) > 999) or /[\200-\377]/));
1475             }
1476              
1477             ### Return '7bit' if clean; try and encode if not...
1478             ### Note that encodings are not permitted for messages!
1479 2 50       28 return ($unclean
    100          
1480             ? (($type eq 'message') ? 'binary' : 'quoted-printable')
1481             : '7bit');
1482             }
1483             }
1484             else {
1485 1 50       4 return ($type eq 'multipart') ? 'binary' : 'base64';
1486             }
1487             }
1488              
1489             sub suggest_encoding_lite {
1490 22     22 0 22 my $self = shift;
1491 22         48 my ($type) = split '/', $self->effective_type;
1492 22 100       100 return (($type =~ /^(text|message|multipart)$/) ? 'binary' : 'base64');
1493             }
1494              
1495             #------------------------------
1496              
1497             =item sync_headers OPTIONS
1498              
1499             I
1500             This method does a variety of activities which ensure that
1501             the MIME headers of an entity "tree" are in-synch with the body parts
1502             they describe. It can be as expensive an operation as printing
1503             if it involves pre-encoding the body parts; however, the aim is to
1504             produce fairly clean MIME. B
1505             this if processing and re-sending MIME from an outside source.>
1506              
1507             The OPTIONS is a hash, which describes what is to be done.
1508              
1509             =over 4
1510              
1511              
1512             =item Length
1513              
1514             One of the "official unofficial" MIME fields is "Content-Length".
1515             Normally, one doesn't care a whit about this field; however, if
1516             you are preparing output destined for HTTP, you may. The value of
1517             this option dictates what will be done:
1518              
1519             B means to set a C field for every non-multipart
1520             part in the entity, and to blank that field out for every multipart
1521             part in the entity.
1522              
1523             B means that C fields will all
1524             be blanked out. This is fast, painless, and safe.
1525              
1526             B (the default) means to take no action.
1527              
1528              
1529             =item Nonstandard
1530              
1531             Any header field beginning with "Content-" is, according to the RFC,
1532             a MIME field. However, some are non-standard, and may cause problems
1533             with certain MIME readers which interpret them in different ways.
1534              
1535             B means that all such fields will be blanked out. This is
1536             done I the B option (q.v.) is examined and acted upon.
1537              
1538             B (the default) means to take no action.
1539              
1540              
1541             =back
1542              
1543             Returns a true value if everything went okay, a false value otherwise.
1544              
1545             =cut
1546              
1547             sub sync_headers {
1548 5     5 1 11 my $self = shift;
1549 5 100       15 my $opts = ((int(@_) % 2 == 0) ? {@_} : shift);
1550 5         2 my $ENCBODY; ### keep it around until done!
1551              
1552             ### Get options:
1553 5   50     11 my $o_nonstandard = ($opts->{Nonstandard} || 0);
1554 5   50     9 my $o_length = ($opts->{Length} || 0);
1555              
1556             ### Get head:
1557 5         8 my $head = $self->head;
1558              
1559             ### What to do with "nonstandard" MIME fields?
1560 5 50       10 if ($o_nonstandard eq 'ERASE') { ### Erase them...
1561 5         4 my $tag;
1562 5         15 foreach $tag ($head->tags()) {
1563 19 50 66     177 if (($tag =~ /\AContent-/i) &&
1564             ($tag !~ /\AContent-$StandardFields\Z/io)) {
1565 0         0 $head->delete($tag);
1566             }
1567             }
1568             }
1569              
1570             ### What to do with the "Content-Length" MIME field?
1571 5 50       11 if ($o_length eq 'COMPUTE') { ### Compute the content length...
    0          
1572 5         5 my $content_length = '';
1573              
1574             ### We don't have content-lengths in multiparts...
1575 5 100       43 if ($self->is_multipart) { ### multipart...
1576 1         6 $head->delete('Content-length');
1577             }
1578             else { ### singlepart...
1579              
1580             ### Get the encoded body, if we don't have it already:
1581 4 50       7 unless ($ENCBODY) {
1582 4   50     9 $ENCBODY = tmpopen() || die "can't open tmpfile";
1583 4         1124 $self->print_body($ENCBODY); ### write encoded to tmpfile
1584             }
1585              
1586             ### Analyse it:
1587 4         15 $ENCBODY->seek(0,2); ### fast-forward
1588 4         119 $content_length = $ENCBODY->tell; ### get encoded length
1589 4         21 $ENCBODY->seek(0,0); ### rewind
1590              
1591             ### Remember:
1592 4         15 $self->head->replace('Content-length', $content_length);
1593             }
1594             }
1595             elsif ($o_length eq 'ERASE') { ### Erase the content-length...
1596 0         0 $head->delete('Content-length');
1597             }
1598              
1599             ### Done with everything for us!
1600 5         379 undef($ENCBODY);
1601              
1602             ### Recurse:
1603 5         693 my $part;
1604 5 50       10 foreach $part ($self->parts) { $part->sync_headers($opts) or return undef }
  4         11  
1605 5         15 1;
1606             }
1607              
1608             #------------------------------
1609              
1610             =item tidy_body
1611              
1612             I
1613             Currently unimplemented for MIME messages. Does nothing, returns false.
1614              
1615             =cut
1616              
1617             sub tidy_body {
1618 0     0 1 0 usage "MIME::Entity::tidy_body currently does nothing";
1619 0         0 0;
1620             }
1621              
1622             =back
1623              
1624             =cut
1625              
1626              
1627              
1628              
1629              
1630             #==============================
1631              
1632             =head2 Output
1633              
1634             =over 4
1635              
1636             =cut
1637              
1638             #------------------------------
1639              
1640             =item dump_skeleton [FILEHANDLE]
1641              
1642             I
1643             Dump the skeleton of the entity to the given FILEHANDLE, or
1644             to the currently-selected one if none given.
1645              
1646             Each entity is output with an appropriate indentation level,
1647             the following selection of attributes:
1648              
1649             Content-type: multipart/mixed
1650             Effective-type: multipart/mixed
1651             Body-file: NONE
1652             Subject: Hey there!
1653             Num-parts: 2
1654              
1655             This is really just useful for debugging purposes; I make no guarantees
1656             about the consistency of the output format over time.
1657              
1658             =cut
1659              
1660             sub dump_skeleton {
1661 0     0 1 0 my ($self, $fh, $indent) = @_;
1662 0 0       0 $fh or $fh = select;
1663 0 0       0 defined($indent) or $indent = 0;
1664 0         0 my $ind = ' ' x $indent;
1665 0         0 my $part;
1666 18     18   119 no strict 'refs';
  18         23  
  18         3471  
1667              
1668              
1669             ### The content type:
1670 0   0     0 print $fh $ind,"Content-type: ", ($self->mime_type||'UNKNOWN'),"\n";
1671 0   0     0 print $fh $ind,"Effective-type: ", ($self->effective_type||'UNKNOWN'),"\n";
1672              
1673             ### The name of the file containing the body (if any!):
1674 0 0       0 my $path = ($self->bodyhandle ? $self->bodyhandle->path : undef);
1675 0   0     0 print $fh $ind, "Body-file: ", ($path || 'NONE'), "\n";
1676              
1677             ### The recommended file name (thanks to Allen Campbell):
1678 0         0 my $filename = $self->head->recommended_filename;
1679 0 0       0 print $fh $ind, "Recommended-filename: ", $filename, "\n" if ($filename);
1680              
1681             ### The subject (note: already a newline if 2.x!)
1682 0         0 my $subj = $self->head->get('subject',0);
1683 0 0       0 defined($subj) or $subj = '';
1684 0         0 chomp($subj);
1685 0 0       0 print $fh $ind, "Subject: $subj\n" if $subj;
1686              
1687             ### The parts:
1688 0         0 my @parts = $self->parts;
1689 0 0       0 print $fh $ind, "Num-parts: ", int(@parts), "\n" if @parts;
1690 0         0 print $fh $ind, "--\n";
1691 0         0 foreach $part (@parts) {
1692 0         0 $part->dump_skeleton($fh, $indent+1);
1693             }
1694             }
1695              
1696             #------------------------------
1697              
1698             =item print [OUTSTREAM]
1699              
1700             I
1701             Print the entity to the given OUTSTREAM, or to the currently-selected
1702             filehandle if none given. OUTSTREAM can be a filehandle, or any object
1703             that responds to a print() message.
1704              
1705             The entity is output as a valid MIME stream! This means that the
1706             header is always output first, and the body data (if any) will be
1707             encoded if the header says that it should be.
1708             For example, your output may look like this:
1709              
1710             Subject: Greetings
1711             Content-transfer-encoding: base64
1712              
1713             SGkgdGhlcmUhCkJ5ZSB0aGVyZSEK
1714              
1715             I
1716             the preamble, parts, and epilogue are all output with appropriate
1717             boundaries separating each.
1718             Any bodyhandle is ignored:
1719              
1720             Content-type: multipart/mixed; boundary="*----*"
1721             Content-transfer-encoding: 7bit
1722              
1723             [Preamble]
1724             --*----*
1725             [Entity: Part 0]
1726             --*----*
1727             [Entity: Part 1]
1728             --*----*--
1729             [Epilogue]
1730              
1731             I
1732             then we're looking at a normal singlepart entity: the body is output
1733             according to the encoding specified by the header.
1734             If no body exists, a warning is output and the body is treated as empty:
1735              
1736             Content-type: image/gif
1737             Content-transfer-encoding: base64
1738              
1739             [Encoded body]
1740              
1741             I
1742             then we're probably looking at a "re-parsed" singlepart, usually one
1743             of type C (you can get entities like this if you set the
1744             C option on the parser to true).
1745             In this case, the parts are output with single blank lines separating each,
1746             and any bodyhandle is ignored:
1747              
1748             Content-type: message/rfc822
1749             Content-transfer-encoding: 7bit
1750              
1751             [Entity: Part 0]
1752              
1753             [Entity: Part 1]
1754              
1755             In all cases, when outputting a "part" of the entity, this method
1756             is invoked recursively.
1757              
1758             B the output is very likely I going to be identical
1759             to any input you parsed to get this entity. If you're building
1760             some sort of email handler, it's up to you to save this information.
1761              
1762             =cut
1763              
1764 18     18   84 use Symbol;
  18         25  
  18         11943  
1765             sub print {
1766 59     59 1 6931 my ($self, $out) = @_;
1767 59 100       118 $out = select if @_ < 2;
1768 59 100       126 $out = Symbol::qualify($out,scalar(caller)) unless ref($out);
1769              
1770 59         192 $self->print_header($out); ### the header
1771 59         321 $out->print("\n");
1772 59         223 $self->print_body($out); ### the "stuff after the header"
1773             }
1774              
1775             #------------------------------
1776              
1777             =item print_body [OUTSTREAM]
1778              
1779             I
1780             Print the body of the entity to the given OUTSTREAM, or to the
1781             currently-selected filehandle if none given. OUTSTREAM can be a
1782             filehandle, or any object that responds to a print() message.
1783              
1784             The body is output for inclusion in a valid MIME stream; this means
1785             that the body data will be encoded if the header says that it should be.
1786              
1787             B by "body", we mean "the stuff following the header".
1788             A printed multipart body includes the printed representations of its subparts.
1789              
1790             B The body is I in an un-encoded form; however, the idea is that
1791             the transfer encoding is used to determine how it should be I
1792             This means that the C method is always guaranteed to get you
1793             a sendmail-ready stream whose body is consistent with its head.
1794             If you want the I to be output, you can either read it from
1795             the bodyhandle yourself, or use:
1796              
1797             $ent->bodyhandle->print($outstream);
1798              
1799             which uses read() calls to extract the information, and thus will
1800             work with both text and binary bodies.
1801              
1802             B Please supply an OUTSTREAM. This override method differs
1803             from Mail::Internet's behavior, which outputs to the STDOUT if no
1804             filehandle is given: this may lead to confusion.
1805              
1806             =cut
1807              
1808             sub print_body {
1809 75     75 1 2605 my ($self, $out) = @_;
1810 75   33     117 $out ||= select;
1811 75         107 my ($type) = split '/', lc($self->mime_type); ### handle by MIME type
1812              
1813             ### Multipart...
1814 75 100       194 if ($type eq 'multipart') {
    50          
1815 10         22 my $boundary = $self->head->multipart_boundary;
1816              
1817             ### Preamble:
1818 10         32 my $plines = $self->preamble;
1819 10 100       20 if (defined $plines) {
1820             # Defined, so output the preamble if it exists (avoiding additional
1821             # newline as per ticket 60931)
1822 9 100       31 $out->print( join('', @$plines) . "\n") if (@$plines > 0);
1823             } else {
1824             # Undefined, so use default preamble
1825 1         10 $out->print( join('', @$DefPreamble) . "\n" );
1826             }
1827              
1828             ### Parts:
1829 10         22 my $part;
1830 10         21 foreach $part ($self->parts) {
1831 29         129 $out->print("--$boundary\n");
1832 29         139 $part->print($out);
1833 29         50 $out->print("\n"); ### needed for next delim/close
1834             }
1835 10         59 $out->print("--$boundary--\n");
1836              
1837             ### Epilogue:
1838 10 100       32 my $epilogue = join('', @{ $self->epilogue || $DefEpilogue });
  10         24  
1839 10 100       30 if ($epilogue ne '') {
1840 1         2 $out->print($epilogue);
1841 1 50       7 $out->print("\n") if ($epilogue !~ /\n\Z/); ### be nice
1842             }
1843             }
1844              
1845             ### Singlepart type with parts...
1846             ### This makes $ent->print handle message/rfc822 bodies
1847             ### when parse_nested_messages('NEST') is on [idea by Marc Rouleau].
1848             elsif ($self->parts) {
1849 0         0 my $need_sep = 0;
1850 0         0 my $part;
1851 0         0 foreach $part ($self->parts) {
1852 0 0       0 $out->print("\n\n") if $need_sep++;
1853 0         0 $part->print($out);
1854             }
1855             }
1856              
1857             ### Singlepart type, or no parts: output body...
1858             else {
1859 65 50       116 $self->bodyhandle ? $self->print_bodyhandle($out)
1860             : whine "missing body; treated as empty";
1861             }
1862 75         112 1;
1863             }
1864              
1865             #------------------------------
1866             #
1867             # print_bodyhandle
1868             #
1869             # Instance method, unpublicized. Print just the bodyhandle, *encoded*.
1870             #
1871             # WARNING: $self->print_bodyhandle() != $self->bodyhandle->print()!
1872             # The former encodes, and the latter does not!
1873             #
1874             sub print_bodyhandle {
1875 65     65 0 57 my ($self, $out) = @_;
1876 65   33     99 $out ||= select;
1877              
1878 65   50     108 my $IO = $self->open("r") || die "open body: $!";
1879 65 100       1267 if ( $self->bodyhandle->is_encoded ) {
1880             ### Transparent mode: data is already encoded, so no
1881             ### need to encode it again
1882 7         5 my $buf;
1883 7         17 $out->print($buf) while ($IO->read($buf, 8192));
1884             } else {
1885             ### Get the encoding, defaulting to "binary" if unsupported:
1886 58   50     87 my $encoding = ($self->head->mime_encoding || 'binary');
1887 58         224 my $decoder = best MIME::Decoder $encoding;
1888 58         102 $decoder->head($self->head); ### associate with head, if any
1889 58 100       81 $decoder->encode($IO, $out, textual_type($self->head->mime_type) ? 1 : 0) || return error "encoding failed";
    50          
1890             }
1891              
1892 65         235 $IO->close;
1893 65         469 1;
1894             }
1895              
1896             #------------------------------
1897              
1898             =item print_header [OUTSTREAM]
1899              
1900             I
1901             Output the header to the given OUTSTREAM. You really should supply
1902             the OUTSTREAM.
1903              
1904             =cut
1905              
1906             ### Inherited.
1907              
1908             #------------------------------
1909              
1910             =item stringify
1911              
1912             I
1913             Return the entity as a string, exactly as C would print it.
1914             The body will be encoded as necessary, and will contain any subparts.
1915             You can also use C.
1916              
1917             =cut
1918              
1919             sub stringify {
1920 15     15 1 307 my ($self) = @_;
1921 15         14 my $output = '';
1922 15 50       69 my $fh = IO::File->new( \$output, '>:' ) or croak("Cannot open in-memory file: $!");
1923 15         1361 $self->print($fh);
1924 15         29 $fh->close;
1925 15         83 return $output;
1926             }
1927              
1928 14     14 1 2960 sub as_string { shift->stringify }; ### silent BC
1929              
1930             #------------------------------
1931              
1932             =item stringify_body
1933              
1934             I
1935             Return the I message body as a string, exactly as C
1936             would print it. You can also use C.
1937              
1938             If you want the I body, and you are dealing with a
1939             singlepart message (like a "text/plain"), use C instead:
1940              
1941             if ($ent->bodyhandle) {
1942             $unencoded_data = $ent->bodyhandle->as_string;
1943             }
1944             else {
1945             ### this message has no body data (but it might have parts!)
1946             }
1947              
1948             =cut
1949              
1950             sub stringify_body {
1951 0     0 1   my ($self) = @_;
1952 0           my $output = '';
1953 0 0         my $fh = IO::File->new( \$output, '>:' ) or croak("Cannot open in-memory file: $!");
1954 0           $self->print_body($fh);
1955 0           $fh->close;
1956 0           return $output;
1957             }
1958              
1959 0     0 0   sub body_as_string { shift->stringify_body }
1960              
1961             #------------------------------
1962              
1963             =item stringify_header
1964              
1965             I
1966             Return the header as a string, exactly as C would print it.
1967             You can also use C.
1968              
1969             =cut
1970              
1971             sub stringify_header {
1972 0     0 1   shift->head->stringify;
1973             }
1974 0     0 0   sub header_as_string { shift->stringify_header }
1975              
1976              
1977             1;
1978             __END__