← Index
NYTProf Performance Profile   « line view »
For /usr/local/libexec/sympa/task_manager-debug.pl
  Run on Tue Jun 1 22:32:51 2021
Reported on Tue Jun 1 22:35:12 2021

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