← 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:13 2021

Filename/usr/local/lib/perl5/site_perl/MIME/Parser.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sMIME::Parser::::BEGIN@129MIME::Parser::BEGIN@129
0000s0sMIME::Parser::::BEGIN@130MIME::Parser::BEGIN@130
0000s0sMIME::Parser::::BEGIN@133MIME::Parser::BEGIN@133
0000s0sMIME::Parser::::BEGIN@134MIME::Parser::BEGIN@134
0000s0sMIME::Parser::::BEGIN@135MIME::Parser::BEGIN@135
0000s0sMIME::Parser::::BEGIN@136MIME::Parser::BEGIN@136
0000s0sMIME::Parser::::BEGIN@137MIME::Parser::BEGIN@137
0000s0sMIME::Parser::::BEGIN@140MIME::Parser::BEGIN@140
0000s0sMIME::Parser::::BEGIN@141MIME::Parser::BEGIN@141
0000s0sMIME::Parser::::BEGIN@142MIME::Parser::BEGIN@142
0000s0sMIME::Parser::::BEGIN@143MIME::Parser::BEGIN@143
0000s0sMIME::Parser::::BEGIN@144MIME::Parser::BEGIN@144
0000s0sMIME::Parser::::BEGIN@145MIME::Parser::BEGIN@145
0000s0sMIME::Parser::::BEGIN@146MIME::Parser::BEGIN@146
0000s0sMIME::Parser::::BEGIN@147MIME::Parser::BEGIN@147
0000s0sMIME::Parser::::__ANON__MIME::Parser::__ANON__ (xsub)
0000s0sMIME::Parser::::debugMIME::Parser::debug
0000s0sMIME::Parser::::decode_bodiesMIME::Parser::decode_bodies
0000s0sMIME::Parser::::decode_headersMIME::Parser::decode_headers
0000s0sMIME::Parser::::errorMIME::Parser::error
0000s0sMIME::Parser::::evil_filenameMIME::Parser::evil_filename
0000s0sMIME::Parser::::extract_nested_messagesMIME::Parser::extract_nested_messages
0000s0sMIME::Parser::::extract_uuencodeMIME::Parser::extract_uuencode
0000s0sMIME::Parser::::filerMIME::Parser::filer
0000s0sMIME::Parser::::hunt_for_uuencodeMIME::Parser::hunt_for_uuencode
0000s0sMIME::Parser::::ignore_errorsMIME::Parser::ignore_errors
0000s0sMIME::Parser::::initMIME::Parser::init
0000s0sMIME::Parser::::init_parseMIME::Parser::init_parse
0000s0sMIME::Parser::::interfaceMIME::Parser::interface
0000s0sMIME::Parser::::last_errorMIME::Parser::last_error
0000s0sMIME::Parser::::last_headMIME::Parser::last_head
0000s0sMIME::Parser::::max_partsMIME::Parser::max_parts
0000s0sMIME::Parser::::newMIME::Parser::new
0000s0sMIME::Parser::::new_body_forMIME::Parser::new_body_for
0000s0sMIME::Parser::::new_tmpfileMIME::Parser::new_tmpfile
0000s0sMIME::Parser::::output_dirMIME::Parser::output_dir
0000s0sMIME::Parser::::output_pathMIME::Parser::output_path
0000s0sMIME::Parser::::output_prefixMIME::Parser::output_prefix
0000s0sMIME::Parser::::output_to_coreMIME::Parser::output_to_core
0000s0sMIME::Parser::::output_underMIME::Parser::output_under
0000s0sMIME::Parser::::parseMIME::Parser::parse
0000s0sMIME::Parser::::parse_FHMIME::Parser::parse_FH
0000s0sMIME::Parser::::parse_dataMIME::Parser::parse_data
0000s0sMIME::Parser::::parse_inMIME::Parser::parse_in
0000s0sMIME::Parser::::parse_nested_messagesMIME::Parser::parse_nested_messages
0000s0sMIME::Parser::::parse_openMIME::Parser::parse_open
0000s0sMIME::Parser::::parse_twoMIME::Parser::parse_two
0000s0sMIME::Parser::::process_epilogueMIME::Parser::process_epilogue
0000s0sMIME::Parser::::process_headerMIME::Parser::process_header
0000s0sMIME::Parser::::process_messageMIME::Parser::process_message
0000s0sMIME::Parser::::process_multipartMIME::Parser::process_multipart
0000s0sMIME::Parser::::process_partMIME::Parser::process_part
0000s0sMIME::Parser::::process_preambleMIME::Parser::process_preamble
0000s0sMIME::Parser::::process_singlepartMIME::Parser::process_singlepart
0000s0sMIME::Parser::::process_to_boundMIME::Parser::process_to_bound
0000s0sMIME::Parser::::readMIME::Parser::read
0000s0sMIME::Parser::::resultsMIME::Parser::results
0000s0sMIME::Parser::::tmp_dirMIME::Parser::tmp_dir
0000s0sMIME::Parser::::tmp_recyclingMIME::Parser::tmp_recycling
0000s0sMIME::Parser::::tmp_to_coreMIME::Parser::tmp_to_core
0000s0sMIME::Parser::::use_inner_filesMIME::Parser::use_inner_files
0000s0sMIME::Parser::::whineMIME::Parser::whine
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package MIME::Parser;
2
3
4=head1 NAME
5
6MIME::Parser - experimental class for parsing MIME streams
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=head2 Basic usage examples
18
19 ### Create a new parser object:
20 my $parser = new MIME::Parser;
21
22 ### Tell it where to put things:
23 $parser->output_under("/tmp");
24
25 ### Parse an input filehandle:
26 $entity = $parser->parse(\*STDIN);
27
28 ### Congratulations: you now have a (possibly multipart) MIME entity!
29 $entity->dump_skeleton; # for debugging
30
31
32=head2 Examples of input
33
34 ### Parse from filehandles:
35 $entity = $parser->parse(\*STDIN);
36 $entity = $parser->parse(IO::File->new("some command|");
37
38 ### Parse from any object that supports getline() and read():
39 $entity = $parser->parse($myHandle);
40
41 ### Parse an in-core MIME message:
42 $entity = $parser->parse_data($message);
43
44 ### Parse an MIME message in a file:
45 $entity = $parser->parse_open("/some/file.msg");
46
47 ### Parse an MIME message out of a pipeline:
48 $entity = $parser->parse_open("gunzip - < file.msg.gz |");
49
50 ### Parse already-split input (as "deliver" would give it to you):
51 $entity = $parser->parse_two("msg.head", "msg.body");
52
53
54=head2 Examples of output control
55
56 ### Keep parsed message bodies in core (default outputs to disk):
57 $parser->output_to_core(1);
58
59 ### Output each message body to a one-per-message directory:
60 $parser->output_under("/tmp");
61
62 ### Output each message body to the same directory:
63 $parser->output_dir("/tmp");
64
65 ### Change how nameless message-component files are named:
66 $parser->output_prefix("msg");
67
68 ### Put temporary files somewhere else
69 $parser->tmp_dir("/var/tmp/mytmpdir");
70
71=head2 Examples of error recovery
72
73 ### Normal mechanism:
74 eval { $entity = $parser->parse(\*STDIN) };
75 if ($@) {
76 $results = $parser->results;
77 $decapitated = $parser->last_head; ### get last top-level head
78 }
79
80 ### Ultra-tolerant mechanism:
81 $parser->ignore_errors(1);
82 $entity = eval { $parser->parse(\*STDIN) };
83 $error = ($@ || $parser->last_error);
84
85 ### Cleanup all files created by the parse:
86 eval { $entity = $parser->parse(\*STDIN) };
87 ...
88 $parser->filer->purge;
89
90
91=head2 Examples of parser options
92
93 ### Automatically attempt to RFC 2047-decode the MIME headers?
94 $parser->decode_headers(1); ### default is false
95
96 ### Parse contained "message/rfc822" objects as nested MIME streams?
97 $parser->extract_nested_messages(0); ### default is true
98
99 ### Look for uuencode in "text" messages, and extract it?
100 $parser->extract_uuencode(1); ### default is false
101
102 ### Should we forgive normally-fatal errors?
103 $parser->ignore_errors(0); ### default is true
104
105
106=head2 Miscellaneous examples
107
108 ### Convert a Mail::Internet object to a MIME::Entity:
109 my $data = join('', (@{$mail->header}, "\n", @{$mail->body}));
110 $entity = $parser->parse_data(\$data);
111
- -
114=head1 DESCRIPTION
115
116You can inherit from this class to create your own subclasses
117that parse MIME streams into MIME::Entity objects.
118
119
120=head1 PUBLIC INTERFACE
121
122=cut
123
124#------------------------------
125
126require 5.004;
127
128### Pragmas:
129use strict;
130use vars (qw($VERSION $CAT $CRLF));
131
132### core Perl modules
133use IO::File;
134use File::Spec;
135use File::Path;
136use Config qw(%Config);
137use Carp;
138
139### Kit modules:
140use MIME::Tools qw(:config :utils :msgtypes usage tmpopen );
141use MIME::Head;
142use MIME::Body;
143use MIME::Entity;
144use MIME::Decoder;
145use MIME::Parser::Reader;
146use MIME::Parser::Filer;
147use MIME::Parser::Results;
148
149#------------------------------
150#
151# Globals
152#
153#------------------------------
154
155### The package version, both in 1.23 style *and* usable by MakeMaker:
156$VERSION = "5.509";
157
158### How to catenate:
159$CAT = '/bin/cat';
160
161### The CRLF sequence:
162$CRLF = "\015\012";
163
164### Who am I?
165my $ME = 'MIME::Parser';
166
- -
169#------------------------------------------------------------
170
171=head2 Construction
172
173=over 4
174
175=cut
176
177#------------------------------
178
179=item new ARGS...
180
181I<Class method.>
182Create a new parser object.
183Once you do this, you can then set up various parameters
184before doing the actual parsing. For example:
185
186 my $parser = new MIME::Parser;
187 $parser->output_dir("/tmp");
188 $parser->output_prefix("msg1");
189 my $entity = $parser->parse(\*STDIN);
190
191Any arguments are passed into C<init()>.
192Don't override this in your subclasses; override init() instead.
193
194=cut
195
196sub new {
197 my $self = bless {}, shift;
198 $self->init(@_);
199}
200
201#------------------------------
202
203=item init ARGS...
204
205I<Instance method.>
206Initiallize a new MIME::Parser object.
207This is automatically sent to a new object; you may want to override it.
208If you override this, be sure to invoke the inherited method.
209
210=cut
211
212sub init {
213 my $self = shift;
214
215 $self->{MP5_DecodeHeaders} = 0;
216 $self->{MP5_DecodeBodies} = 1;
217 $self->{MP5_Interface} = {};
218 $self->{MP5_ParseNested} = 'NEST';
219 $self->{MP5_TmpToCore} = 0;
220 $self->{MP5_IgnoreErrors} = 1;
221 $self->{MP5_UUDecode} = 0;
222 $self->{MP5_MaxParts} = -1;
223 $self->{MP5_TmpDir} = undef;
224
225 $self->interface(ENTITY_CLASS => 'MIME::Entity');
226 $self->interface(HEAD_CLASS => 'MIME::Head');
227
228 $self->output_dir(".");
229
230 $self;
231}
232
233#------------------------------
234
235=item init_parse
236
237I<Instance method.>
238Invoked automatically whenever one of the top-level parse() methods
239is called, to reset the parser to a "ready" state.
240
241=cut
242
243sub init_parse {
244 my $self = shift;
245
246 $self->{MP5_Results} = new MIME::Parser::Results;
247
248 $self->{MP5_Filer}->results($self->{MP5_Results});
249 $self->{MP5_Filer}->purgeable([]);
250 $self->{MP5_Filer}->init_parse();
251 $self->{MP5_NumParts} = 0;
252 1;
253}
254
255=back
256
257=cut
258
- -
263#------------------------------------------------------------
264
265=head2 Altering how messages are parsed
266
267=over 4
268
269=cut
270
271#------------------------------
272
273=item decode_headers [YESNO]
274
275I<Instance method.>
276Controls whether the parser will attempt to decode all the MIME headers
277(as per RFC 2047) the moment it sees them. B<This is not advisable
278for two very important reasons:>
279
280=over
281
282=item *
283
284B<It screws up the extraction of information from MIME fields.>
285If you fully decode the headers into bytes, you can inadvertently
286transform a parseable MIME header like this:
287
288 Content-type: text/plain; filename="=?ISO-8859-1?Q?Hi=22Ho?="
289
290into unparseable gobbledygook; in this case:
291
292 Content-type: text/plain; filename="Hi"Ho"
293
294=item *
295
296B<It is information-lossy.> An encoded string which contains
297both Latin-1 and Cyrillic characters will be turned into a binary
298mishmosh which simply can't be rendered.
299
300=back
301
302B<History.>
303This method was once the only out-of-the-box way to deal with attachments
304whose filenames had non-ASCII characters. However, since MIME-tools 5.4xx
305this is no longer necessary.
306
307B<Parameters.>
308If YESNO is true, decoding is done. However, you will get a warning
309unless you use one of the special "true" values:
310
311 "I_NEED_TO_FIX_THIS"
312 Just shut up and do it. Not recommended.
313 Provided only for those who need to keep old scripts functioning.
314
315 "I_KNOW_WHAT_I_AM_DOING"
316 Just shut up and do it. Not recommended.
317 Provided for those who REALLY know what they are doing.
318
319If YESNO is false (the default), no attempt at decoding will be done.
320With no argument, just returns the current setting.
321B<Remember:> you can always decode the headers I<after> the parsing
322has completed (see L<MIME::Head::decode()|MIME::Head/decode>), or
323decode the words on demand (see L<MIME::Words>).
324
325=cut
326
327sub decode_headers {
328 my ($self, $yesno) = @_;
329 if (@_ > 1) {
330 $self->{MP5_DecodeHeaders} = $yesno;
331 if ($yesno) {
332 if (($yesno eq "I_KNOW_WHAT_I_AM_DOING") ||
333 ($yesno eq "I_NEED_TO_FIX_THIS")) {
334 ### ok
335 }
336 else {
337 $self->whine("as of 5.4xx, decode_headers() should NOT be ".
338 "set true... if you are doing this to make sure ".
339 "that non-ASCII filenames are translated, ".
340 "that's now done automatically; for all else, ".
341 "use MIME::Words.");
342 }
343 }
344 }
345 $self->{MP5_DecodeHeaders};
346}
347
348#------------------------------
349
350=item extract_nested_messages OPTION
351
352I<Instance method.>
353Some MIME messages will contain a part of type C<message/rfc822>
354,C<message/partial> or C<message/external-body>:
355literally, the text of an embedded mail/news/whatever message.
356This option controls whether (and how) we parse that embedded message.
357
358If the OPTION is false, we treat such a message just as if it were a
359C<text/plain> document, without attempting to decode its contents.
360
361If the OPTION is true (the default), the body of the C<message/rfc822>
362or C<message/partial> part is parsed by this parser, creating an
363entity object. What happens then is determined by the actual OPTION:
364
365=over 4
366
367=item NEST or 1
368
369The default setting.
370The contained message becomes the sole "part" of the C<message/rfc822>
371entity (as if the containing message were a special kind of
372"multipart" message).
373You can recover the sub-entity by invoking the L<parts()|MIME::Entity/parts>
374method on the C<message/rfc822> entity.
375
376=item REPLACE
377
378The contained message replaces the C<message/rfc822> entity, as though
379the C<message/rfc822> "container" never existed.
380
381B<Warning:> notice that, with this option, all the header information
382in the C<message/rfc822> header is lost. This might seriously bother
383you if you're dealing with a top-level message, and you've just lost
384the sender's address and the subject line. C<:-/>.
385
386=back
387
388I<Thanks to Andreas Koenig for suggesting this method.>
389
390=cut
391
392sub extract_nested_messages {
393 my ($self, $option) = @_;
394 $self->{MP5_ParseNested} = $option if (@_ > 1);
395 $self->{MP5_ParseNested};
396}
397
398sub parse_nested_messages {
399 usage "parse_nested_messages() is now extract_nested_messages()";
400 shift->extract_nested_messages(@_);
401}
402
403#------------------------------
404
405=item extract_uuencode [YESNO]
406
407I<Instance method.>
408If set true, then whenever we are confronted with a message
409whose effective content-type is "text/plain" and whose encoding
410is 7bit/8bit/binary, we scan the encoded body to see if it contains
411uuencoded data (generally given away by a "begin XXX" line).
412
413If it does, we explode the uuencoded message into a multipart,
414where the text before the first "begin XXX" becomes the first part,
415and all "begin...end" sections following become the subsequent parts.
416The filename (if given) is accessible through the normal means.
417
418=cut
419
420sub extract_uuencode {
421 my ($self, $yesno) = @_;
422 $self->{MP5_UUDecode} = $yesno if @_ > 1;
423 $self->{MP5_UUDecode};
424}
425
426#------------------------------
427
428=item ignore_errors [YESNO]
429
430I<Instance method.>
431Controls whether the parser will attempt to ignore normally-fatal
432errors, treating them as warnings and continuing with the parse.
433
434If YESNO is true (the default), many syntax errors are tolerated.
435If YESNO is false, fatal errors throw exceptions.
436With no argument, just returns the current setting.
437
438=cut
439
440sub ignore_errors {
441 my ($self, $yesno) = @_;
442 $self->{MP5_IgnoreErrors} = $yesno if (@_ > 1);
443 $self->{MP5_IgnoreErrors};
444}
445
446
447#------------------------------
448
449=item decode_bodies [YESNO]
450
451I<Instance method.>
452Controls whether the parser should decode entity bodies or not.
453If this is set to a false value (default is true), all entity bodies
454will be kept as-is in the original content-transfer encoding.
455
456To prevent double encoding on the output side MIME::Body->is_encoded
457is set, which tells MIME::Body not to encode the data again, if encoded
458data was requested. This is in particular useful, when it's important that
459the content B<must not> be modified, e.g. if you want to calculate
460OpenPGP signatures from it.
461
462B<WARNING>: the semantics change significantly if you parse MIME
463messages with this option set, because MIME::Entity resp. MIME::Body
464*always* see encoded data now, while the default behaviour is
465working with *decoded* data (and encoding it only if you request it).
466You need to decode the data yourself, if you want to have it decoded.
467
468So use this option only if you exactly know, what you're doing, and
469that you're sure, that you really need it.
470
471=cut
472
473sub decode_bodies {
474 my ($self, $yesno) = @_;
475 $self->{MP5_DecodeBodies} = $yesno if (@_ > 1);
476 $self->{MP5_DecodeBodies};
477}
478
479#------------------------------
480#
481# MESSAGES...
482#
483
484#------------------------------
485#
486# debug MESSAGE...
487#
488sub debug {
489 my $self = shift;
490 if (MIME::Tools->debugging()) {
491 if (my $r = $self->{MP5_Results}) {
492 unshift @_, $r->indent;
493 $r->msg($M_DEBUG, @_);
494 }
495 MIME::Tools::debug(@_);
496 }
497}
498
499#------------------------------
500#
501# whine PROBLEM...
502#
503sub whine {
504 my $self = shift;
505 if (my $r = $self->{MP5_Results}) {
506 unshift @_, $r->indent;
507 $r->msg($M_WARNING, @_);
508 }
509 &MIME::Tools::whine(@_);
510}
511
512#------------------------------
513#
514# error PROBLEM...
515#
516# Possibly-forgivable parse error occurred.
517# Raises a fatal exception unless we are ignoring errors.
518#
519sub error {
520 my $self = shift;
521 if (my $r = $self->{MP5_Results}) {
522 unshift @_, $r->indent;
523 $r->msg($M_ERROR, @_);
524 }
525 &MIME::Tools::error(@_);
526 $self->{MP5_IgnoreErrors} ? return undef : die @_;
527}
528
- -
532#------------------------------
533#
534# PARSING...
535#
536
537#------------------------------
538#
539# process_preamble IN, READER, ENTITY
540#
541# I<Instance method.>
542# Dispose of a multipart message's preamble.
543#
544sub process_preamble {
545 my ($self, $in, $rdr, $ent) = @_;
546
547 ### Sanity:
548 ($rdr->depth > 0) or die "$ME: internal logic error";
549
550 ### Parse preamble:
551 my @saved;
552 my $data = '';
553 open(my $fh, '>', \$data) or die $!;
554 $rdr->read_chunk($in, $fh, 1);
555 close $fh;
556
557 # Ugh. Horrible. If the preamble consists only of CRLF, squash it down
558 # to the empty string. Else, remove the trailing CRLF.
559 if( $data =~ m/^[\r\n]\z/ ) {
560 @saved = ('');
561 } else {
562 $data =~ s/[\r\n]\z//;
563 @saved = split(/^/, $data);
564 }
565 $ent->preamble(\@saved);
566 1;
567}
568
569#------------------------------
570#
571# process_epilogue IN, READER, ENTITY
572#
573# I<Instance method.>
574# Dispose of a multipart message's epilogue.
575#
576sub process_epilogue {
577 my ($self, $in, $rdr, $ent) = @_;
578 $self->debug("process_epilogue");
579
580 ### Parse epilogue:
581 my @saved;
582 $rdr->read_lines($in, \@saved);
583 $ent->epilogue(\@saved);
584 1;
585}
586
587#------------------------------
588#
589# process_to_bound IN, READER, OUT
590#
591# I<Instance method.>
592# Dispose of the next chunk into the given output stream OUT.
593#
594sub process_to_bound {
595 my ($self, $in, $rdr, $out) = @_;
596
597 ### Parse:
598 $rdr->read_chunk($in, $out);
599 1;
600}
601
602#------------------------------
603#
604# process_header IN, READER
605#
606# I<Instance method.>
607# Process and return the next header.
608# Return undef if, instead of a header, the encapsulation boundary is found.
609# Fatal exception on failure.
610#
611sub process_header {
612 my ($self, $in, $rdr) = @_;
613 $self->debug("process_header");
614
615 ### Parse and save the (possibly empty) header, up to and including the
616 ### blank line that terminates it:
617 my $head = $self->interface('HEAD_CLASS')->new;
618
619 ### Read the lines of the header.
620 ### We localize IO inside here, so that we can support the IO:: interface
621 my @headlines;
622 my $hdr_rdr = $rdr->spawn;
623 $hdr_rdr->add_terminator("");
624 $hdr_rdr->add_terminator("\r"); ### sigh
625
626 my $headstr = '';
627 open(my $outfh, '>:scalar', \$headstr) or die $!;
628 $hdr_rdr->read_chunk($in, $outfh, 0, 1);
629 close $outfh;
630
631 ### How did we do?
632 if ($hdr_rdr->eos_type eq 'DELIM') {
633 $self->whine("bogus part, without CRLF before body");
634 return undef;
635 }
636 ($hdr_rdr->eos_type eq 'DONE') or
637 $self->error("unexpected end of header\n");
638
639 ### Extract the header (note that zero-size headers are admissible!):
640 open(my $readfh, '<:scalar', \$headstr) or die $!;
641 $head->read( $readfh );
642
643 unless( $readfh->eof() ) {
644 # Not entirely correct, since ->read consumes the line it gives up on.
645 # it's actually the line /before/ the one we get with ->getline
646 $self->error("couldn't parse head; error near:\n", $readfh->getline());
647 }
648
649
650 ### If desired, auto-decode the header as per RFC 2047
651 ### This shouldn't affect non-encoded headers; however, it will decode
652 ### headers with international characters. WARNING: currently, the
653 ### character-set information is LOST after decoding.
654 $head->decode($self->{MP5_DecodeHeaders}) if $self->{MP5_DecodeHeaders};
655
656 ### If this is the top-level head, save it:
657 $self->results->top_head($head) if !$self->results->top_head;
658
659 return $head;
660}
661
662#------------------------------
663#
664# process_multipart IN, READER, ENTITY
665#
666# I<Instance method.>
667# Process the multipart body, and return the state.
668# Fatal exception on failure.
669# Invoked by process_part().
670#
671sub process_multipart {
672 my ($self, $in, $rdr, $ent) = @_;
673 my $head = $ent->head;
674
675 $self->debug("process_multipart...");
676
677 ### Get actual type and subtype from the header:
678 my ($type, $subtype) = (split('/', $head->mime_type, -1), '');
679
680 ### If this was a type "multipart/digest", then the RFCs say we
681 ### should default the parts to have type "message/rfc822".
682 ### Thanks to Carsten Heyl for suggesting this...
683 my $retype = (($subtype eq 'digest') ? 'message/rfc822' : '');
684
685 ### Get the boundaries for the parts:
686 my $bound = $head->multipart_boundary;
687 if (!defined($bound) || ($bound =~ /[\r\n]/)) {
688 $self->error("multipart boundary is missing, or contains CR or LF\n");
689 $ent->effective_type("application/x-unparseable-multipart");
690 return $self->process_singlepart($in, $rdr, $ent);
691 }
692 my $part_rdr = $rdr->spawn->add_boundary($bound);
693
694 ### Prepare to parse:
695 my $eos_type;
696 my $more_parts;
697
698 ### Parse preamble...
699 $self->process_preamble($in, $part_rdr, $ent);
700
701 ### ...and look at how we finished up:
702 $eos_type = $part_rdr->eos_type;
703 if ($eos_type eq 'DELIM'){ $more_parts = 1 }
704 elsif ($eos_type eq 'CLOSE'){ $self->whine("empty multipart message\n");
705 $more_parts = 0; }
706 else { $self->error("unexpected end of preamble\n");
707 return 1; }
708
709 ### Parse parts:
710 my $partno = 0;
711 my $part;
712 while ($more_parts) {
713 ++$partno;
714 $self->debug("parsing part $partno...");
715
716 ### Parse the next part, and add it to the entity...
717 my $part = $self->process_part($in, $part_rdr, Retype=>$retype);
718 return undef unless defined($part);
719
720 $ent->add_part($part);
721
722 ### ...and look at how we finished up:
723 $eos_type = $part_rdr->eos_type;
724 if ($eos_type eq 'DELIM') { $more_parts = 1 }
725 elsif ($eos_type eq 'CLOSE') { $more_parts = 0; }
726 else { $self->error("unexpected end of parts ".
727 "before epilogue\n");
728 return 1; }
729 }
730
731 ### Parse epilogue...
732 ### (note that we use the *parent's* reader here, which does not
733 ### know about the boundaries in this multipart!)
734 $self->process_epilogue($in, $rdr, $ent);
735
736 ### ...and there's no need to look at how we finished up!
737 1;
738}
739
740#------------------------------
741#
742# process_singlepart IN, READER, ENTITY
743#
744# I<Instance method.>
745# Process the singlepart body. Returns true.
746# Fatal exception on failure.
747# Invoked by process_part().
748#
749sub process_singlepart {
750 my ($self, $in, $rdr, $ent) = @_;
751 my $head = $ent->head;
752
753 $self->debug("process_singlepart...");
754
755 ### Obtain a filehandle for reading the encoded information:
756 ### We have two different approaches, based on whether or not we
757 ### have to contend with boundaries.
758 my $ENCODED; ### handle
759 my $can_shortcut = (!$rdr->has_bounds and !$self->{MP5_UUDecode});
760 if ($can_shortcut) {
761 $self->debug("taking shortcut");
762
763 $ENCODED = $in;
764 $rdr->eos('EOF'); ### be sure to bogus-up the reader state to EOF:
765 }
766 else {
767
768 $self->debug("using temp file");
769 $ENCODED = $self->new_tmpfile();
770
771 ### Read encoded body until boundary (or EOF)...
772 $self->process_to_bound($in, $rdr, $ENCODED);
773
774 ### ...and look at how we finished up.
775 ### If we have bounds, we want DELIM or CLOSE.
776 ### Otherwise, we want EOF (and that's all we'd get, anyway!).
777 if ($rdr->has_bounds) {
778 ($rdr->eos_type =~ /^(DELIM|CLOSE)$/) or
779 $self->error("part did not end with expected boundary\n");
780 }
781
782 ### Flush and rewind encoded buffer, so we can read it:
783 $ENCODED->flush or die "$ME: can't flush: $!";
784 $ENCODED->seek(0, 0) or die "$ME: can't seek: $!";
785 }
786
787 ### Get a content-decoder to decode this part's encoding:
788 my $encoding = $head->mime_encoding;
789 my $decoder = new MIME::Decoder $encoding;
790 if (!$decoder) {
791 $self->whine("Unsupported encoding '$encoding': using 'binary'... \n".
792 "The entity will have an effective MIME type of \n".
793 "application/octet-stream."); ### as per RFC-2045
794 $ent->effective_type('application/octet-stream');
795 $decoder = new MIME::Decoder 'binary';
796 $encoding = 'binary';
797 }
798
799 ### Data should be stored encoded / as-is?
800 if ( !$self->decode_bodies ) {
801 $decoder = new MIME::Decoder 'binary';
802 $encoding = 'binary';
803 }
804
805 ### If desired, sidetrack to troll for UUENCODE:
806 $self->debug("extract uuencode? ", $self->extract_uuencode);
807 $self->debug("encoding? ", $encoding);
808 $self->debug("effective type? ", $ent->effective_type);
809
810 if ($self->extract_uuencode and
811 ($encoding =~ /^(7bit|8bit|binary)\Z/) and
812 ($ent->effective_type =~
813 m{^(?:text/plain|application/mac-binhex40|application/mac-binhex)\Z})) {
814 ### Hunt for it:
815 my $uu_ent = eval { $self->hunt_for_uuencode($ENCODED, $ent) };
816 if ($uu_ent) { ### snark
817 %$ent = %$uu_ent;
818 return 1;
819 }
820 else { ### boojum
821 $self->whine("while hunting for uuencode: $@");
822 $ENCODED->seek(0,0) or die "$ME: can't seek: $!";
823 }
824 }
825
826 ### Open a new bodyhandle for outputting the data:
827 my $body = $self->new_body_for($head) or die "$ME: no body"; # gotta die
828 $body->binmode(1) or die "$ME: can't set to binmode: $!"
829 unless textual_type($ent->effective_type) or !$self->decode_bodies;
830 $body->is_encoded(1) if !$self->decode_bodies;
831
832 ### Decode and save the body (using the decoder):
833 my $DECODED = $body->open("w") or die "$ME: body not opened: $!";
834 eval { $decoder->decode($ENCODED, $DECODED); };
835 $@ and $self->error($@);
836 $DECODED->close or die "$ME: can't close: $!";
837
838 ### Success! Remember where we put stuff:
839 $ent->bodyhandle($body);
840
841 ### Done!
842 1;
843}
844
845#------------------------------
846#
847# hunt_for_uuencode ENCODED, ENTITY
848#
849# I<Instance method.>
850# Try to detect and dispatch embedded uuencode as a fake multipart message.
851# Returns new entity or undef.
852#
853sub hunt_for_uuencode {
854 my ($self, $ENCODED, $ent) = @_;
855 my ($good, $how_encoded);
856 local $_;
857 $self->debug("sniffing around for UUENCODE");
858
859 ### Heuristic:
860 $ENCODED->seek(0,0) or die "$ME: can't seek: $!";
861 while (defined($_ = $ENCODED->getline)) {
862 if ($good = /^begin [0-7]{3}/) {
863 $how_encoded = 'uu';
864 last;
865 }
866 if ($good = /^\(This file must be converted with/i) {
867 $how_encoded = 'binhex';
868 last;
869 }
870 }
871 $good or do { $self->debug("no one made the cut"); return 0 };
872
873 # If a decoder doesn't exist for this type, forget it!
874 my $decoder = MIME::Decoder->new(($how_encoded eq 'uu')?'x-uuencode'
875 :'binhex');
876 unless (defined($decoder)) {
877 $self->debug("No decoder for $how_encoded attachments");
878 return 0;
879 }
880
881 ### New entity:
882 my $top_ent = $ent->dup; ### no data yet
883 $top_ent->make_multipart;
884 my @parts;
885
886 ### Made the first cut; on to the real stuff:
887 $ENCODED->seek(0,0) or die "$ME: can't seek: $!";
888 $self->whine("Found a $how_encoded attachment");
889 my $pre;
890 while (1) {
891 my $bin_data = '';
892
893 ### Try next part:
894 my $out = IO::File->new(\$bin_data, '>:');
895 eval { $decoder->decode($ENCODED, $out) }; last if $@;
896 my $preamble = $decoder->last_preamble;
897 my $filename = $decoder->last_filename;
898 my $mode = $decoder->last_mode;
899
900 ### Get probable type:
901 my $type = 'application/octet-stream';
902 my ($ext) = $filename =~ /\.(\w+)\Z/; $ext = lc($ext || '');
903 if ($ext =~ /^(gif|jpe?g|xbm|xpm|png)\Z/) { $type = "image/$1" }
904
905 ### If we got our first preamble, create the text portion:
906 if (@$preamble and
907 (grep /\S/, @$preamble) and
908 !@parts) {
909 my $txt_ent = $self->interface('ENTITY_CLASS')->new;
910
911 MIME::Entity->build(Type => "text/plain",
912 Data => "");
913 $txt_ent->bodyhandle($self->new_body_for($txt_ent->head));
914 my $io = $txt_ent->bodyhandle->open("w") or die "$ME: can't create: $!";
915 $io->print(@$preamble) or die "$ME: can't print: $!";
916 $io->close or die "$ME: can't close: $!";
917 push @parts, $txt_ent;
918 }
919
920 ### Create the attachment:
921 ### We use the x-unix-mode convention from "dtmail 1.2.1 SunOS 5.6".
922 if (1) {
923 my $bin_ent = MIME::Entity->build(Type=>$type,
924 Filename=>$filename,
925 Data=>"");
926 $bin_ent->head->mime_attr('Content-type.x-unix-mode' => "0$mode");
927 $bin_ent->bodyhandle($self->new_body_for($bin_ent->head));
928 $bin_ent->bodyhandle->binmode(1) or die "$ME: can't set to binmode: $!";
929 my $io = $bin_ent->bodyhandle->open("w") or die "$ME: can't create: $!";
930 $io->print($bin_data) or die "$ME: can't print: $!";
931 $io->close or die "$ME: can't close: $!";
932 push @parts, $bin_ent;
933 }
934 }
935
936 ### Did we get anything?
937 @parts or return undef;
938 ### Set the parts and a nice preamble:
939 $top_ent->parts(\@parts);
940 $top_ent->preamble
941 (["The following is a multipart MIME message which was extracted\n",
942 "from a $how_encoded-encoded message.\n"]);
943 $top_ent;
944}
945
946#------------------------------
947#
948# process_message IN, READER, ENTITY
949#
950# I<Instance method.>
951# Process the singlepart body, and return true.
952# Fatal exception on failure.
953# Invoked by process_part().
954#
955sub process_message {
956 my ($self, $in, $rdr, $ent) = @_;
957 my $head = $ent->head;
958
959 $self->debug("process_message");
960
961 ### Verify the encoding restrictions:
962 my $encoding = $head->mime_encoding;
963 if ($encoding !~ /^(7bit|8bit|binary)$/) {
964 $self->error("illegal encoding [$encoding] for MIME type ".
965 $head->mime_type."\n");
966 $encoding = 'binary';
967 }
968
969 ### Parse the message:
970 my $msg = $self->process_part($in, $rdr);
971 return undef unless defined($msg);
972
973 ### How to handle nested messages?
974 if ($self->extract_nested_messages eq 'REPLACE') {
975 %$ent = %$msg; ### shallow replace
976 %$msg = ();
977 }
978 else { ### "NEST" or generic 1:
979 $ent->bodyhandle(undef);
980 $ent->add_part($msg);
981 }
982 1;
983}
984
985#------------------------------
986#
987# process_part IN, READER, [OPTSHASH...]
988#
989# I<Instance method.>
990# The real back-end engine.
991# See the documentation up top for the overview of the algorithm.
992# The OPTSHASH can contain:
993#
994# Retype => retype this part to the given content-type
995#
996# Return the entity.
997# Fatal exception on failure. Returns undef if message to complex
998#
999sub process_part {
1000 my ($self, $in, $rdr, %p) = @_;
1001
1002 if ($self->{MP5_MaxParts} > 0) {
1003 $self->{MP5_NumParts}++;
1004 if ($self->{MP5_NumParts} > $self->{MP5_MaxParts}) {
1005 # Return UNDEF if msg too complex
1006 return undef;
1007 }
1008 }
1009
1010 $rdr ||= MIME::Parser::Reader->new;
1011 #debug "process_part";
1012 $self->results->level(+1);
1013
1014 ### Create a new entity:
1015 my $ent = $self->interface('ENTITY_CLASS')->new;
1016
1017 ### Parse and add the header:
1018 my $head = $self->process_header($in, $rdr);
1019 if (not defined $head) {
1020 $self->debug("bogus empty part");
1021 $head = $self->interface('HEAD_CLASS')->new;
1022 $head->mime_type('text/plain');
1023 $ent->head($head);
1024 $ent->bodyhandle($self->new_body_for($head));
1025 $ent->bodyhandle->open("w")->close or die "$ME: can't close: $!";
1026 $self->results->level(-1);
1027 return $ent;
1028 }
1029 $ent->head($head);
1030
1031 ### Tweak the content-type based on context from our parent...
1032 ### For example, multipart/digest messages default to type message/rfc822:
1033 $head->mime_type($p{Retype}) if $p{Retype};
1034
1035 ### Get the MIME type and subtype:
1036 my ($type, $subtype) = (split('/', $head->mime_type, -1), '');
1037 $self->debug("type = $type, subtype = $subtype");
1038
1039 ### Handle, according to the MIME type:
1040 if ($type eq 'multipart') {
1041 return undef unless defined($self->process_multipart($in, $rdr, $ent));
1042 }
1043 elsif (("$type/$subtype" eq "message/rfc822" ||
1044 "$type/$subtype" eq "message/external-body" ||
1045 ("$type/$subtype" eq "message/partial" && defined($head->mime_attr("content-type.number")) && $head->mime_attr("content-type.number") == 1)) &&
1046 $self->extract_nested_messages) {
1047 $self->debug("attempting to process a nested message");
1048 return undef unless defined($self->process_message($in, $rdr, $ent));
1049 }
1050 else {
1051 $self->process_singlepart($in, $rdr, $ent);
1052 }
1053
1054 ### Done (we hope!):
1055 $self->results->level(-1);
1056 return $ent;
1057}
1058
- -
1061=back
1062
1063=head2 Parsing an input source
1064
1065=over 4
1066
1067=cut
1068
1069#------------------------------
1070
1071=item parse_data DATA
1072
1073I<Instance method.>
1074Parse a MIME message that's already in core. This internally creates an "in
1075memory" filehandle on a Perl scalar value using PerlIO
1076
1077You may supply the DATA in any of a number of ways...
1078
1079=over 4
1080
1081=item *
1082
1083B<A scalar> which holds the message. A reference to this scalar will be used
1084internally.
1085
1086=item *
1087
1088B<A ref to a scalar> which holds the message. This reference will be used
1089internally.
1090
1091=item *
1092
1093B<DEPRECATED>
1094
1095B<A ref to an array of scalars.> The array is internally concatenated into a
1096temporary string, and a reference to the new string is used internally.
1097
1098It is much more efficient to pass in a scalar reference, so please consider
1099refactoring your code to use that interface instead. If you absolutely MUST
1100pass an array, you may be better off using IO::ScalarArray in the calling code
1101to generate a filehandle, and passing that filehandle to I<parse()>
1102
1103=back
1104
1105Returns the parsed MIME::Entity on success.
1106
1107=cut
1108
1109sub parse_data {
1110 my ($self, $data) = @_;
1111
1112 if (!defined($data)) {
1113 croak "parse_data: No data passed";
1114 }
1115
1116 ### Get data as a scalar:
1117 my $io;
1118
1119 if (! ref $data ) {
1120 $io = IO::File->new(\$data, '<:');
1121 } elsif( ref $data eq 'SCALAR' ) {
1122 $io = IO::File->new($data, '<:');
1123 } elsif( ref $data eq 'ARRAY' ) {
1124 # Passing arrays is deprecated now that we've nuked IO::ScalarArray
1125 # but for backwards compatibility we still support it by joining the
1126 # array lines to a scalar and doing scalar IO on it.
1127 my $tmp_data = join('', @$data);
1128 $io = IO::File->new(\$tmp_data, '<:');
1129 } else {
1130 croak "parse_data: wrong argument ref type: ", ref($data);
1131 }
1132
1133 if (!$io) {
1134 croak "parse_data: unable to open in-memory file handle";
1135 }
1136
1137 ### Parse!
1138 return $self->parse($io);
1139}
1140
1141#------------------------------
1142
1143=item parse INSTREAM
1144
1145I<Instance method.>
1146Takes a MIME-stream and splits it into its component entities.
1147
1148The INSTREAM can be given as an IO::File, a globref filehandle (like
1149C<\*STDIN>), or as I<any> blessed object conforming to the IO::
1150interface (which minimally implements getline() and read()).
1151
1152Returns the parsed MIME::Entity on success.
1153Throws exception on failure. If the message contained too many
1154parts (as set by I<max_parts>), returns undef.
1155
1156=cut
1157
1158sub parse {
1159 my $self = shift;
1160 my $in = shift;
1161 my $entity;
1162 local $/ = "\n"; ### just to be safe
1163
1164 local $\ = undef; # CPAN ticket #71041
1165 $self->init_parse;
1166 $entity = $self->process_part($in, undef); ### parse!
1167
1168 $entity;
1169}
1170
1171### Backcompat:
1172sub read {
1173 shift->parse(@_);
1174}
1175sub parse_FH {
1176 shift->parse(@_);
1177}
1178
1179#------------------------------
1180
1181=item parse_open EXPR
1182
1183I<Instance method.>
1184Convenience front-end onto C<parse()>.
1185Simply give this method any expression that may be sent as the second
1186argument to open() to open a filehandle for reading.
1187
1188Returns the parsed MIME::Entity on success.
1189Throws exception on failure.
1190
1191=cut
1192
1193sub parse_open {
1194 my ($self, $expr) = @_;
1195 my $ent;
1196
1197 my $io = IO::File->new($expr) or die "$ME: couldn't open $expr: $!";
1198 $ent = $self->parse($io);
1199 $io->close or die "$ME: can't close: $!";
1200 $ent;
1201}
1202
1203### Backcompat:
1204sub parse_in {
1205 usage "parse_in() is now parse_open()";
1206 shift->parse_open(@_);
1207}
1208
1209#------------------------------
1210
1211=item parse_two HEADFILE, BODYFILE
1212
1213I<Instance method.>
1214Convenience front-end onto C<parse_open()>, intended for programs
1215running under mail-handlers like B<deliver>, which splits the incoming
1216mail message into a header file and a body file.
1217Simply give this method the paths to the respective files.
1218
1219B<Warning:> it is assumed that, once the files are cat'ed together,
1220there will be a blank line separating the head part and the body part.
1221
1222B<Warning:> new implementation slurps files into line array
1223for portability, instead of using 'cat'. May be an issue if
1224your messages are large.
1225
1226Returns the parsed MIME::Entity on success.
1227Throws exception on failure.
1228
1229=cut
1230
1231sub parse_two {
1232 my ($self, $headfile, $bodyfile) = @_;
1233 my $data;
1234 foreach ($headfile, $bodyfile) {
1235 open IN, "<$_" or die "$ME: open $_: $!";
1236 $data .= do { local $/; <IN> };
1237 close IN or die "$ME: can't close: $!";
1238 }
1239 return $self->parse_data($data);
1240}
1241
1242=back
1243
1244=cut
1245
- -
1249#------------------------------------------------------------
1250
1251=head2 Specifying output destination
1252
1253B<Warning:> in 5.212 and before, this was done by methods
1254of MIME::Parser. However, since many users have requested
1255fine-tuned control over how this is done, the logic has been split
1256off from the parser into its own class, MIME::Parser::Filer
1257Every MIME::Parser maintains an instance of a MIME::Parser::Filer
1258subclass to manage disk output (see L<MIME::Parser::Filer> for details.)
1259
1260The benefit to this is that the MIME::Parser code won't be
1261confounded with a lot of garbage related to disk output.
1262The drawback is that the way you override the default behavior
1263will change.
1264
1265For now, all the normal public-interface methods are still provided,
1266but many are only stubs which create or delegate to the underlying
1267MIME::Parser::Filer object.
1268
1269=over 4
1270
1271=cut
1272
1273#------------------------------
1274
1275=item filer [FILER]
1276
1277I<Instance method.>
1278Get/set the FILER object used to manage the output of files to disk.
1279This will be some subclass of L<MIME::Parser::Filer|MIME::Parser::Filer>.
1280
1281=cut
1282
1283sub filer {
1284 my ($self, $filer) = @_;
1285 if (@_ > 1) {
1286 $self->{MP5_Filer} = $filer;
1287 $filer->results($self->results); ### but we still need in init_parse
1288 }
1289 $self->{MP5_Filer};
1290}
1291
1292#------------------------------
1293
1294=item output_dir DIRECTORY
1295
1296I<Instance method.>
1297Causes messages to be filed directly into the given DIRECTORY.
1298It does this by setting the underlying L<filer()|/filer> to
1299a new instance of MIME::Parser::FileInto, and passing the arguments
1300into that class' new() method.
1301
1302B<Note:> Since this method replaces the underlying
1303filer, you must invoke it I<before> doing changing any attributes
1304of the filer, like the output prefix; otherwise those changes
1305will be lost.
1306
1307=cut
1308
1309sub output_dir {
1310 my ($self, @init) = @_;
1311 if (@_ > 1) {
1312 $self->filer(MIME::Parser::FileInto->new(@init));
1313 }
1314 else {
1315 &MIME::Tools::whine("0-arg form of output_dir is deprecated.");
1316 return $self->filer->output_dir;
1317 }
1318}
1319
1320#------------------------------
1321
1322=item output_under BASEDIR, OPTS...
1323
1324I<Instance method.>
1325Causes messages to be filed directly into subdirectories of the given
1326BASEDIR, one subdirectory per message. It does this by setting the
1327underlying L<filer()|/filer> to a new instance of MIME::Parser::FileUnder,
1328and passing the arguments into that class' new() method.
1329
1330B<Note:> Since this method replaces the underlying
1331filer, you must invoke it I<before> doing changing any attributes
1332of the filer, like the output prefix; otherwise those changes
1333will be lost.
1334
1335=cut
1336
1337sub output_under {
1338 my ($self, @init) = @_;
1339 if (@_ > 1) {
1340 $self->filer(MIME::Parser::FileUnder->new(@init));
1341 }
1342 else {
1343 &MIME::Tools::whine("0-arg form of output_under is deprecated.");
1344 return $self->filer->output_dir;
1345 }
1346}
1347
1348#------------------------------
1349
1350=item output_path HEAD
1351
1352I<Instance method, DEPRECATED.>
1353Given a MIME head for a file to be extracted, come up with a good
1354output pathname for the extracted file.
1355Identical to the preferred form:
1356
1357 $parser->filer->output_path(...args...);
1358
1359We just delegate this to the underlying L<filer()|/filer> object.
1360
1361=cut
1362
1363sub output_path {
1364 my $self = shift;
1365 ### We use it, so don't warn!
1366 ### &MIME::Tools::whine("output_path deprecated in MIME::Parser");
1367 $self->filer->output_path(@_);
1368}
1369
1370#------------------------------
1371
1372=item output_prefix [PREFIX]
1373
1374I<Instance method, DEPRECATED.>
1375Get/set the short string that all filenames for extracted body-parts
1376will begin with (assuming that there is no better "recommended filename").
1377Identical to the preferred form:
1378
1379 $parser->filer->output_prefix(...args...);
1380
1381We just delegate this to the underlying L<filer()|/filer> object.
1382
1383=cut
1384
1385sub output_prefix {
1386 my $self = shift;
1387 &MIME::Tools::whine("output_prefix deprecated in MIME::Parser");
1388 $self->filer->output_prefix(@_);
1389}
1390
1391#------------------------------
1392
1393=item evil_filename NAME
1394
1395I<Instance method, DEPRECATED.>
1396Identical to the preferred form:
1397
1398 $parser->filer->evil_filename(...args...);
1399
1400We just delegate this to the underlying L<filer()|/filer> object.
1401
1402=cut
1403
1404sub evil_filename {
1405 my $self = shift;
1406 &MIME::Tools::whine("evil_filename deprecated in MIME::Parser");
1407 $self->filer->evil_filename(@_);
1408}
1409
1410#------------------------------
1411
1412=item max_parts NUM
1413
1414I<Instance method.>
1415Limits the number of MIME parts we will parse.
1416
1417Normally, instances of this class parse a message to the bitter end.
1418Messages with many MIME parts can cause excessive memory consumption.
1419If you invoke this method, parsing will abort with a die() if a message
1420contains more than NUM parts.
1421
1422If NUM is set to -1 (the default), then no maximum limit is enforced.
1423
1424With no argument, returns the current setting as an integer
1425
1426=cut
1427
1428sub max_parts {
1429 my($self, $num) = @_;
1430 if (@_ > 1) {
1431 $self->{MP5_MaxParts} = $num;
1432 }
1433 return $self->{MP5_MaxParts};
1434}
1435
1436#------------------------------
1437
1438=item output_to_core YESNO
1439
1440I<Instance method.>
1441Normally, instances of this class output all their decoded body
1442data to disk files (via MIME::Body::File). However, you can change
1443this behaviour by invoking this method before parsing:
1444
1445If YESNO is false (the default), then all body data goes
1446to disk files.
1447
1448If YESNO is true, then all body data goes to in-core data structures
1449This is a little risky (what if someone emails you an MPEG or a tar
1450file, hmmm?) but people seem to want this bit of noose-shaped rope,
1451so I'm providing it.
1452Note that setting this attribute true I<does not> mean that parser-internal
1453temporary files are avoided! Use L<tmp_to_core()|/tmp_to_core> for that.
1454
1455With no argument, returns the current setting as a boolean.
1456
1457=cut
1458
1459sub output_to_core {
1460 my ($self, $yesno) = @_;
1461 if (@_ > 1) {
1462 $yesno = 0 if ($yesno and $yesno eq 'NONE');
1463 $self->{MP5_FilerToCore} = $yesno;
1464 }
1465 $self->{MP5_FilerToCore};
1466}
1467
1468
1469=item tmp_recycling
1470
1471I<Instance method, DEPRECATED.>
1472
1473This method is a no-op to preserve the pre-5.421 API.
1474
1475The tmp_recycling() feature was removed in 5.421 because it had never actually
1476worked. Please update your code to stop using it.
1477
1478=cut
1479
1480sub tmp_recycling
1481{
1482 return;
1483}
1484
- -
1487#------------------------------
1488
1489=item tmp_to_core [YESNO]
1490
1491I<Instance method.>
1492Should L<new_tmpfile()|/new_tmpfile> create real temp files, or
1493use fake in-core ones? Normally we allow the creation of temporary
1494disk files, since this allows us to handle huge attachments even when
1495core is limited.
1496
1497If YESNO is true, we implement new_tmpfile() via in-core handles.
1498If YESNO is false (the default), we use real tmpfiles.
1499With no argument, just returns the current setting.
1500
1501=cut
1502
1503sub tmp_to_core {
1504 my ($self, $yesno) = @_;
1505 $self->{MP5_TmpToCore} = $yesno if (@_ > 1);
1506 $self->{MP5_TmpToCore};
1507}
1508
1509#------------------------------
1510
1511=item use_inner_files [YESNO]
1512
1513I<REMOVED>.
1514
1515I<Instance method.>
1516
1517MIME::Parser no longer supports IO::InnerFile, but this method is retained for
1518backwards compatibility. It does nothing.
1519
1520The original reasoning for IO::InnerFile was that inner files were faster than
1521"in-core" temp files. At the time, the "in-core" tempfile support was
1522implemented with IO::Scalar from the IO-Stringy distribution, which used the
1523tie() interface to wrap a scalar with the appropriate IO::Handle operations.
1524The penalty for this was fairly hefty, and IO::InnerFile actually was faster.
1525
1526Nowadays, MIME::Parser uses Perl's built in ability to open a filehandle on an
1527in-memory scalar variable via PerlIO. Benchmarking shows that IO::InnerFile is
1528slightly slower than using in-memory temporary files, and is slightly faster
1529than on-disk temporary files. Both measurements are within a few percent of
1530each other. Since there's no real benefit, and since the IO::InnerFile abuse
1531was fairly hairy and evil ("writes" to it were faked by extending the size of
1532the inner file with the assumption that the only data you'd ever ->print() to
1533it would be the line from the "outer" file, for example) it's been removed.
1534
1535=cut
1536
1537sub use_inner_files {
1538 return 0;
1539}
1540
1541=back
1542
1543=cut
1544
1545
1546#------------------------------------------------------------
1547
1548=head2 Specifying classes to be instantiated
1549
1550=over 4
1551
1552=cut
1553
1554#------------------------------
1555
1556=item interface ROLE,[VALUE]
1557
1558I<Instance method.>
1559During parsing, the parser normally creates instances of certain classes,
1560like MIME::Entity. However, you may want to create a parser subclass
1561that uses your own experimental head, entity, etc. classes (for example,
1562your "head" class may provide some additional MIME-field-oriented methods).
1563
1564If so, then this is the method that your subclass should invoke during
1565init. Use it like this:
1566
1567 package MyParser;
1568 @ISA = qw(MIME::Parser);
1569 ...
1570 sub init {
1571 my $self = shift;
1572 $self->SUPER::init(@_); ### do my parent's init
1573 $self->interface(ENTITY_CLASS => 'MIME::MyEntity');
1574 $self->interface(HEAD_CLASS => 'MIME::MyHead');
1575 $self; ### return
1576 }
1577
1578With no VALUE, returns the VALUE currently associated with that ROLE.
1579
1580=cut
1581
1582sub interface {
1583 my ($self, $role, $value) = @_;
1584 $self->{MP5_Interface}{$role} = $value if (defined($value));
1585 $self->{MP5_Interface}{$role};
1586}
1587
1588#------------------------------
1589
1590=item new_body_for HEAD
1591
1592I<Instance method.>
1593Based on the HEAD of a part we are parsing, return a new
1594body object (any desirable subclass of MIME::Body) for
1595receiving that part's data.
1596
1597If you set the C<output_to_core> option to false before parsing
1598(the default), then we call C<output_path()> and create a
1599new MIME::Body::File on that filename.
1600
1601If you set the C<output_to_core> option to true before parsing,
1602then you get a MIME::Body::InCore instead.
1603
1604If you want the parser to do something else entirely, you can
1605override this method in a subclass.
1606
1607=cut
1608
1609sub new_body_for {
1610 my ($self, $head) = @_;
1611
1612 if ($self->output_to_core) {
1613 $self->debug("outputting body to core");
1614 return (new MIME::Body::InCore);
1615 }
1616 else {
1617 my $outpath = $self->output_path($head);
1618 $self->debug("outputting body to disk file: $outpath");
1619 $self->filer->purgeable($outpath); ### we plan to use it
1620 return (new MIME::Body::File $outpath);
1621 }
1622}
1623
1624#------------------------------
1625
1626=pod
1627
1628=back
1629
1630=head2 Temporary File Creation
1631
1632=over
1633
1634=item tmp_dir DIRECTORY
1635
1636I<Instance method.>
1637Causes any temporary files created by this parser to be created in the
1638given DIRECTORY.
1639
1640If called without arguments, returns current value.
1641
1642The default value is undef, which will cause new_tmpfile() to use the
1643system default temporary directory.
1644
1645=cut
1646
1647sub tmp_dir
1648{
1649 my ($self, $dirname) = @_;
1650 if ( $dirname ) {
1651 $self->{MP5_TmpDir} = $dirname;
1652 }
1653
1654 return $self->{MP5_TmpDir};
1655}
1656
1657=item new_tmpfile
1658
1659I<Instance method.>
1660Return an IO handle to be used to hold temporary data during a parse.
1661
1662The default uses MIME::Tools::tmpopen() to create a new temporary file,
1663unless L<tmp_to_core()|/tmp_to_core> dictates otherwise, but you can
1664override this. You shouldn't need to.
1665
1666The location for temporary files can be changed on a per-parser basis
1667with L<tmp_dir()>.
1668
1669If you do override this, make certain that the object you return is
1670set for binmode(), and is able to handle the following methods:
1671
1672 read(BUF, NBYTES)
1673 getline()
1674 getlines()
1675 print(@ARGS)
1676 flush()
1677 seek(0, 0)
1678
1679Fatal exception if the stream could not be established.
1680
1681=cut
1682
1683sub new_tmpfile {
1684 my ($self) = @_;
1685
1686 my $io;
1687 if ($self->{MP5_TmpToCore}) {
1688 my $var;
1689 $io = IO::File->new(\$var, '+>:') or die "$ME: Can't open in-core tmpfile: $!";
1690 } else {
1691 my $args = {};
1692 if( $self->tmp_dir ) {
1693 $args->{DIR} = $self->tmp_dir;
1694 }
1695 $io = tmpopen( $args ) or die "$ME: can't open tmpfile: $!\n";
1696 binmode($io) or die "$ME: can't set to binmode: $!";
1697 }
1698 return $io;
1699}
1700
1701=back
1702
1703=cut
1704
- -
1710#------------------------------------------------------------
1711
1712=head2 Parse results and error recovery
1713
1714=over 4
1715
1716=cut
1717
1718#------------------------------
1719
1720=item last_error
1721
1722I<Instance method.>
1723Return the error (if any) that we ignored in the last parse.
1724
1725=cut
1726
1727sub last_error {
1728 join '', shift->results->errors;
1729}
1730
1731
1732#------------------------------
1733
1734=item last_head
1735
1736I<Instance method.>
1737Return the top-level MIME header of the last stream we attempted to parse.
1738This is useful for replying to people who sent us bad MIME messages.
1739
1740 ### Parse an input stream:
1741 eval { $entity = $parser->parse(\*STDIN) };
1742 if (!$entity) { ### parse failed!
1743 my $decapitated = $parser->last_head;
1744 ...
1745 }
1746
1747=cut
1748
1749sub last_head {
1750 shift->results->top_head;
1751}
1752
1753#------------------------------
1754
1755=item results
1756
1757I<Instance method.>
1758Return an object containing lots of info from the last entity parsed.
1759This will be an instance of class
1760L<MIME::Parser::Results|MIME::Parser::Results>.
1761
1762=cut
1763
1764sub results {
1765 shift->{MP5_Results};
1766}
1767
1768
1769=back
1770
1771=cut
1772
1773
1774#------------------------------
17751;
1776__END__