Attachment #23406 for bug #36886

Lines 100-105 Link Here

(-)MIME-tools-5.411/lib/MIME/Field/ParamVal.pm (-3 / +78 lines)
100	# token = 1*<any (ASCII) CHAR except SPACE, CTLs, or tspecials>	100	# token = 1*<any (ASCII) CHAR except SPACE, CTLs, or tspecials>
101	#	101	#
102	my $TSPECIAL = '()<>@,;:\</[]?="';	102	my $TSPECIAL = '()<>@,;:\</[]?="';
		103
		104	#" Fix emacs highlighting...
		105
103	my $TOKEN = '[^ \x00-\x1f\x80-\xff' . "\Q$TSPECIAL\E" . ']+';	106	my $TOKEN = '[^ \x00-\x1f\x80-\xff' . "\Q$TSPECIAL\E" . ']+';
104		107
105	# Encoded token:	108	# Encoded token:
Lines 108-113 Link Here
108	# Pattern to match spaces or comments:	111	# Pattern to match spaces or comments:
109	my $SPCZ = '(?:\s\|$[^$]\))';	112	my $SPCZ = '(?:\s\|$[^$]\))';
110		113
		114	# Pattern to match non-semicolon as fallback for broken MIME
		115	# produced by some viruses
		116	my $BADTOKEN = '[^;]+';
111		117
112	#------------------------------	118	#------------------------------
113	#	119	#
Lines 181-190 Link Here
181		187
182	=cut	188	=cut
183		189
		190	sub rfc2231decode {
		191	my($val) = @_;
		192	my($enc, $lang, $rest);
		193
		194	if ($val =~ m/^([^\'])\'([^\'])\'(.*)$/) {
		195	# SHOULD REALLY DO SOMETHING MORE INTELLIGENT WITH ENCODING!!!
		196	$enc = $1;
		197	$lang = $2;
		198	$rest = $3;
		199	$rest = rfc2231percent($rest);
		200	} elsif ($val =~ m/^([^\'])\'([^\'])$/) {
		201	$enc = $1;
		202	$rest = $2;
		203	$rest = rfc2231percent($rest);
		204	} else {
		205	$rest = rfc2231percent($val);
		206	}
		207	return $rest;
		208	}
		209
		210	sub rfc2231percent {
		211	# Do percent-subsitution
		212	my($str) = @_;
		213	$str =~ s/%([0-9a-fA-F]{2})/pack("c", hex($1))/ge;
		214	return $str;
		215	}
		216
		217
184	sub parse_params {	218	sub parse_params {
185	my ($self, $raw) = @_;	219	my ($self, $raw) = @_;
186	my %params = ();	220	my %params = ();
		221	my %rfc2231params = ();
187	my $param;	222	my $param;
		223	my $val;
		224	my $part;
188		225
189	# Get raw field, and unfold it:	226	# Get raw field, and unfold it:
190	defined($raw) or $raw = '';	227	defined($raw) or $raw = '';
Lines 200-208 Link Here
200	$raw =~ m/\G$SPCZ\;$SPCZ/og or last; # skip leading separator	237	$raw =~ m/\G$SPCZ\;$SPCZ/og or last; # skip leading separator
201	$raw =~ m/\G($PARAMNAME)\s=\s/og or last; # give up if not a param	238	$raw =~ m/\G($PARAMNAME)\s=\s/og or last; # give up if not a param
202	$param = lc($1);	239	$param = lc($1);
203	$raw =~ m/\G(\"([^\"]+)\")\|\G($TOKEN)\|\G($ENCTOKEN)/g or last; # give up if no value	240	$raw =~ m/\G(\"([^\"]+)\")\|\G($ENCTOKEN)\|\G($BADTOKEN)\|\G($TOKEN)/g or last; # give up if no value"
204	my ($qstr, $str, $token, $enctoken) = ($1, $2, $3, $4);	241	my ($qstr, $str, $enctoken, $badtoken, $token) = ($1, $2, $3, $4, $5);
205	$params{$param} = defined($qstr) ? $str : (defined($token) ? $token : $enctoken);	242	if (defined($badtoken)) {
		243	# Strip leading/trailing whitespace from badtoken
		244	$badtoken =~ s/^\s*//;
		245	$badtoken =~ s/\s*$//;
		246	}
		247	$val = defined($qstr) ? $str :
		248	(defined($enctoken) ? $enctoken :
		249	(defined($badtoken) ? $badtoken : $token));
		250
		251	# Do RFC 2231 processing
		252	if ($param =~ /\*/) {
		253	my($name, $num);
		254	# Pick out the parts of the parameter
		255	if ($param =~ m/^([^]+)\([^]+)\?$/) {
		256	# We have paramnumber or param*number
		257	$name = $1;
		258	$num = $2;
		259	} else {
		260	# Fake a part of zero... not sure how to handle this properly
		261	$param =~ s/\*//g;
		262	$name = $param;
		263	$num = 0;
		264	}
		265	# Decode the value unless it was a quoted string
		266	if (!defined($qstr)) {
		267	$val = rfc2231decode($val);
		268	}
		269	$rfc2231params{$name}{$num} .= $val;
		270	} else {
		271	# Make a fake "part zero" for non-RFC2231 params
		272	$rfc2231params{$param}{"0"} = $val;
		273	}
		274	}
		275
		276	# Extract reconstructed parameters
		277	foreach $param (keys %rfc2231params) {
		278	foreach $part (sort { $a <=> $b } keys %{$rfc2231params{$param}}) {
		279	$params{$param} .= $rfc2231params{$param}{$part};
		280	}
206	debug " field param <$param> = <$params{$param}>";	281	debug " field param <$param> = <$params{$param}>";
207	}	282	}
208		283




    $self->{MP5_IgnoreErrors}    = 1;
    $self->{MP5_UseInnerFiles}   = 0;
    $self->{MP5_UUDecode}        = 0;
    $self->{MP5_MaxParts}        = -1;

    $self->interface(ENTITY_CLASS => 'MIME::Entity');
    $self->interface(HEAD_CLASS   => 'MIME::Head');

    $self->{MP5_Filer}->results($self->{MP5_Results});
    $self->{MP5_Filer}->init_parse();
    $self->{MP5_Filer}->purgeable([]);   ### just to be safe
    $self->{MP5_NumParts} = 0;
    1;
}


=item extract_nested_messages OPTION

I<Instance method.>
Some MIME messages will contain a part of type C<message/rfc822>
or C<message/partial>:
literally, the text of an embedded mail/news/whatever message.  
This option controls whether (and how) we parse that embedded message.


C<text/plain> document, without attempting to decode its contents.  

If the OPTION is true (the default), the body of the C<message/rfc822> 
or C<message/partial> part is parsed by this parser, creating an
entity object.  What happens then is determined by the actual OPTION:

=over 4


	
	### Parse the next part, and add it to the entity...
	my $part = $self->process_part($in, $part_rdr, Retype=>$retype);
	return undef unless defined($part);
	
	
	$ent->add_part($part);

	### ...and look at how we finished up:


    ### Parse the message:
    my $msg = $self->process_part($in, $rdr);
    return undef unless defined($msg);

    ### How to handle nested messages?
    if ($self->extract_nested_messages eq 'REPLACE') {

#    Retype => retype this part to the given content-type
#
# Return the entity.
# Fatal exception on failure.  Returns undef if message to complex
#
#
sub process_part {
    my ($self, $in, $rdr, %p) = @_;

    if ($self->{MP5_MaxParts} > 0) {
       	$self->{MP5_NumParts}++;
       	if ($self->{MP5_NumParts} > $self->{MP5_MaxParts}) {
          # Return UNDEF if msg too complex
          return undef;
       }
    }
    $rdr ||= MIME::Parser::Reader->new;
    #debug "process_part";
    $self->results->level(+1);


    ### Handle, according to the MIME type:
    if ($type eq 'multipart') {
       return undef unless defined($self->process_multipart($in, $rdr, $ent));
    }
    elsif (("$type/$subtype" eq "message/rfc822" ||
           ("$type/$subtype" eq "message/partial" && $head->mime_attr("content-type.number") == 1)) &&
           $self->extract_nested_messages) {
	$self->debug("attempting to process a nested message");
	return undef unless defined($self->process_message($in, $rdr, $ent));
    }
    else {                     
	$self->process_singlepart($in, $rdr, $ent);

=back

Returns the parsed MIME::Entity on success.  
Throws exception on failure.

=cut


(which minimally implements getline() and read()).

Returns the parsed MIME::Entity on success.  
Throws exception on failure.  If the message contained too many
parts (as set by I<max_parts>), returns undef.

=cut



    my $bm = benchmark {
	$self->init_parse;
	$entity = $self->process_part($in, undef);  ### parse!
    };
    $self->debug("t parse: $bm");



#------------------------------

=item max_parts NUM

I<Instance method.>
Limits the number of MIME parts we will parse.

Normally, instances of this class parse a message to the bitter end.
Messages with many MIME parts can cause excessive memory consumption.
If you invoke this method, parsing will abort with a die() if a message
contains more than NUM parts.

If NUM is set to -1 (the default), then no maximum limit is enforced.

With no argument, returns the current setting as an integer

=cut

sub max_parts {
    my($self, $num) = @_;
    if (@_ > 1) {
       $self->{MP5_MaxParts} = $num;
    }
    return $self->{MP5_MaxParts};
}

#------------------------------


=item output_to_core YESNO

I<Instance method.>

Lines 186-192 Link Here

(-)MIME-tools-5.411/lib/MIME/Words.pm (-1 / +1 lines)
186	$@ = ''; ### error-return	186	$@ = ''; ### error-return
187		187
188	### Collapse boundaries between adjacent encoded words:	188	### Collapse boundaries between adjacent encoded words:
189	$encstr =~ s{(\?\=)\r?\n[ \t](\=\?)}{$1$2}gs;	189	$encstr =~ s{(\?\=)\s*(\=\?)}{$1$2}gs;
190	pos($encstr) = 0;	190	pos($encstr) = 0;
191	### print STDOUT "ENC = [", $encstr, "]\n";	191	### print STDOUT "ENC = [", $encstr, "]\n";
192		192

Return to bug 36886

Lines 250-255 Link Here

(-)MIME-tools-5.411/lib/MIME/Parser.pm (-11 / +54 lines)
250	$self->{MP5_IgnoreErrors} = 1;	250	$self->{MP5_IgnoreErrors} = 1;
251	$self->{MP5_UseInnerFiles} = 0;	251	$self->{MP5_UseInnerFiles} = 0;
252	$self->{MP5_UUDecode} = 0;	252	$self->{MP5_UUDecode} = 0;
		253	$self->{MP5_MaxParts} = -1;
253		254
254	$self->interface(ENTITY_CLASS => 'MIME::Entity');	255	$self->interface(ENTITY_CLASS => 'MIME::Entity');
255	$self->interface(HEAD_CLASS => 'MIME::Head');	256	$self->interface(HEAD_CLASS => 'MIME::Head');
Lines 277-282 Link Here
277	$self->{MP5_Filer}->results($self->{MP5_Results});	278	$self->{MP5_Filer}->results($self->{MP5_Results});
278	$self->{MP5_Filer}->init_parse();	279	$self->{MP5_Filer}->init_parse();
279	$self->{MP5_Filer}->purgeable([]); ### just to be safe	280	$self->{MP5_Filer}->purgeable([]); ### just to be safe
		281	$self->{MP5_NumParts} = 0;
280	1;	282	1;
281	}	283	}
282		284
Lines 378-384 Link Here
378	=item extract_nested_messages OPTION	380	=item extract_nested_messages OPTION
379		381
380	I<Instance method.>	382	I<Instance method.>
381	Some MIME messages will contain a part of type C<message/rfc822>:	383	Some MIME messages will contain a part of type C<message/rfc822>
		384	or C<message/partial>:
382	literally, the text of an embedded mail/news/whatever message.	385	literally, the text of an embedded mail/news/whatever message.
383	This option controls whether (and how) we parse that embedded message.	386	This option controls whether (and how) we parse that embedded message.
384		387
Lines 386-393 Link Here
386	C<text/plain> document, without attempting to decode its contents.	389	C<text/plain> document, without attempting to decode its contents.
387		390
388	If the OPTION is true (the default), the body of the C<message/rfc822>	391	If the OPTION is true (the default), the body of the C<message/rfc822>
389	part is parsed by this parser, creating an entity object.	392	or C<message/partial> part is parsed by this parser, creating an
390	What happens then is determined by the actual OPTION:	393	entity object. What happens then is determined by the actual OPTION:
391		394
392	=over 4	395	=over 4
393		396
Lines 705-710 Link Here
705		708
706	### Parse the next part, and add it to the entity...	709	### Parse the next part, and add it to the entity...
707	my $part = $self->process_part($in, $part_rdr, Retype=>$retype);	710	my $part = $self->process_part($in, $part_rdr, Retype=>$retype);
		711	return undef unless defined($part);
		712
		713
708	$ent->add_part($part);	714	$ent->add_part($part);
709		715
710	### ...and look at how we finished up:	716	### ...and look at how we finished up:
Lines 944-949 Link Here
944		950
945	### Parse the message:	951	### Parse the message:
946	my $msg = $self->process_part($in, $rdr);	952	my $msg = $self->process_part($in, $rdr);
		953	return undef unless defined($msg);
947		954
948	### How to handle nested messages?	955	### How to handle nested messages?
949	if ($self->extract_nested_messages eq 'REPLACE') {	956	if ($self->extract_nested_messages eq 'REPLACE') {
Lines 969-979 Link Here
969	# Retype => retype this part to the given content-type	976	# Retype => retype this part to the given content-type
970	#	977	#
971	# Return the entity.	978	# Return the entity.
972	# Fatal exception on failure.	979	# Fatal exception on failure. Returns undef if message to complex
		980	#
973	#	981	#
974	sub process_part {	982	sub process_part {
975	my ($self, $in, $rdr, %p) = @_;	983	my ($self, $in, $rdr, %p) = @_;
976		984
		985	if ($self->{MP5_MaxParts} > 0) {
		986	$self->{MP5_NumParts}++;
		987	if ($self->{MP5_NumParts} > $self->{MP5_MaxParts}) {
		988	# Return UNDEF if msg too complex
		989	return undef;
		990	}
		991	}
977	$rdr \|\|= MIME::Parser::Reader->new;	992	$rdr \|\|= MIME::Parser::Reader->new;
978	#debug "process_part";	993	#debug "process_part";
979	$self->results->level(+1);	994	$self->results->level(+1);
Lines 995-1006 Link Here
995		1010
996	### Handle, according to the MIME type:	1011	### Handle, according to the MIME type:
997	if ($type eq 'multipart') {	1012	if ($type eq 'multipart') {
998	$self->process_multipart($in, $rdr, $ent);	1013	return undef unless defined($self->process_multipart($in, $rdr, $ent));
999	}	1014	}
1000	elsif (("$type/$subtype" eq "message/rfc822") &&	1015	elsif (("$type/$subtype" eq "message/rfc822" \|\|
1001	$self->extract_nested_messages) {	1016	("$type/$subtype" eq "message/partial" && $head->mime_attr("content-type.number") == 1)) &&
		1017	$self->extract_nested_messages) {
1002	$self->debug("attempting to process a nested message");	1018	$self->debug("attempting to process a nested message");
1003	$self->process_message($in, $rdr, $ent);	1019	return undef unless defined($self->process_message($in, $rdr, $ent));
1004	}	1020	}
1005	else {	1021	else {
1006	$self->process_singlepart($in, $rdr, $ent);	1022	$self->process_singlepart($in, $rdr, $ent);
Lines 1047-1053 Link Here
1047	=back	1063	=back
1048		1064
1049	Returns the parsed MIME::Entity on success.	1065	Returns the parsed MIME::Entity on success.
1050	Throws exception on failure.
1051		1066
1052	=cut	1067	=cut
1053		1068
Lines 1086-1092 Link Here
1086	(which minimally implements getline() and read()).	1101	(which minimally implements getline() and read()).
1087		1102
1088	Returns the parsed MIME::Entity on success.	1103	Returns the parsed MIME::Entity on success.
1089	Throws exception on failure.	1104	Throws exception on failure. If the message contained too many
		1105	parts (as set by I<max_parts>), returns undef.
1090		1106
1091	=cut	1107	=cut
1092		1108
Lines 1098-1104 Link Here
1098		1114
1099	my $bm = benchmark {	1115	my $bm = benchmark {
1100	$self->init_parse;	1116	$self->init_parse;
1101	($entity) = $self->process_part($in, undef); ### parse!	1117	$entity = $self->process_part($in, undef); ### parse!
1102	};	1118	};
1103	$self->debug("t parse: $bm");	1119	$self->debug("t parse: $bm");
1104		1120
Lines 1346-1351 Link Here
1346		1362
1347	#------------------------------	1363	#------------------------------
1348		1364
		1365	=item max_parts NUM
		1366
		1367	I<Instance method.>
		1368	Limits the number of MIME parts we will parse.
		1369
		1370	Normally, instances of this class parse a message to the bitter end.
		1371	Messages with many MIME parts can cause excessive memory consumption.
		1372	If you invoke this method, parsing will abort with a die() if a message
		1373	contains more than NUM parts.
		1374
		1375	If NUM is set to -1 (the default), then no maximum limit is enforced.
		1376
		1377	With no argument, returns the current setting as an integer
		1378
		1379	=cut
		1380
		1381	sub max_parts {
		1382	my($self, $num) = @_;
		1383	if (@_ > 1) {
		1384	$self->{MP5_MaxParts} = $num;
		1385	}
		1386	return $self->{MP5_MaxParts};
		1387	}
		1388
		1389	#------------------------------
		1390
		1391
1349	=item output_to_core YESNO	1392	=item output_to_core YESNO
1350		1393
1351	I<Instance method.>	1394	I<Instance method.>