X-Git-Url: http://www.git.stargrave.org/?a=blobdiff_plain;f=lib%2FPublicInbox%2FEml.pm;h=ef401141c135db358861e83b7271336d9df12f20;hb=8b44e99ec009508d7e050ee44d34a1cf0f111dd5;hp=0c23bed03e5e3413a11fb27b9bc388119199d66d;hpb=57af9c8d0bedafac3267b5b42f963bb8aa5c2ea1;p=public-inbox.git diff --git a/lib/PublicInbox/Eml.pm b/lib/PublicInbox/Eml.pm index 0c23bed0..ef401141 100644 --- a/lib/PublicInbox/Eml.pm +++ b/lib/PublicInbox/Eml.pm @@ -30,19 +30,27 @@ use v5.10.1; use Carp qw(croak); use Encode qw(find_encoding decode encode); # stdlib use Text::Wrap qw(wrap); # stdlib, we need Perl 5.6+ for $huge +use MIME::Base64 3.05; # Perl 5.10.0 / 5.9.2 +use MIME::QuotedPrint 3.05; # ditto my $MIME_Header = find_encoding('MIME-Header'); -# TODO remove these dependencies -use Email::MIME::ContentType; -use Email::MIME::Encodings; -$Email::MIME::ContentType::STRICT_PARAMS = 0; +use PublicInbox::EmlContentFoo qw(parse_content_type parse_content_disposition); +$PublicInbox::EmlContentFoo::STRICT_PARAMS = 0; -our $MAXPARTS = 1000; # same as SpamAssassin -our $MAXDEPTH = 20; # seems enough, Perl sucks, here -our $MAXBOUNDLEN = 2048; # same as postfix +our $mime_parts_limit = 1000; # same as SpamAssassin (not in postfix AFAIK) + +# the rest of the limit names are taken from postfix: +our $mime_nesting_limit = 20; # seems enough, Perl sucks, here +our $mime_boundary_length_limit = 2048; # same as postfix +our $header_size_limit = 102400; # same as postfix + +my %MIME_ENC = (qp => \&enc_qp, base64 => \&encode_base64); +my %MIME_DEC = (qp => \&dec_qp, base64 => \&decode_base64); +$MIME_ENC{quotedprint} = $MIME_ENC{'quoted-printable'} = $MIME_ENC{qp}; +$MIME_DEC{quotedprint} = $MIME_DEC{'quoted-printable'} = $MIME_DEC{qp}; +$MIME_ENC{$_} = \&identity_codec for qw(7bit 8bit binary); -my $NO_ENCODE_RE = qr/\A(?:7bit|8bit|binary)[ \t]*(?:;|$)?/i; my %DECODE_ADDRESS = map { $_ => 1 } qw(From To Cc Sender Reply-To); my %DECODE_FULL = ( Subject => 1, @@ -63,19 +71,47 @@ sub re_memo ($) { /ismx } +sub hdr_truncate ($) { + my $len = length($_[0]); + substr($_[0], $header_size_limit, $len) = ''; + my $end = rindex($_[0], "\n"); + if ($end >= 0) { + ++$end; + substr($_[0], $end, $len) = ''; + warn "header of $len bytes truncated to $end bytes\n"; + } else { + $_[0] = ''; + warn <= 0) { + # likely on *nix + my $hdr = substr($$ref, 0, $pos + 2, ''); # sv_chop on $$ref + chop($hdr); # lower SvCUR + hdr_truncate($hdr) if length($hdr) > $header_size_limit; + bless { hdr => \$hdr, crlf => "\n", bdy => $ref }, __PACKAGE__; + } elsif ($$ref =~ /\r?\n(\r?\n)/s) { + my $hdr = substr($$ref, 0, $+[0], ''); # sv_chop on $$ref substr($hdr, -(length($1))) = ''; # lower SvCUR + hdr_truncate($hdr) if length($hdr) > $header_size_limit; bless { hdr => \$hdr, crlf => $1, bdy => $ref }, __PACKAGE__; } elsif ($$ref =~ /^[a-z0-9-]+[ \t]*:/ims && $$ref =~ /(\r?\n)\z/s) { # body is optional :P - bless { hdr => \($$ref), crlf => $1 }, __PACKAGE__; + my $hdr = substr($$ref, 0, $header_size_limit + 1); + hdr_truncate($hdr) if length($hdr) > $header_size_limit; + bless { hdr => \$hdr, crlf => $1 }, __PACKAGE__; } else { # nothing useful my $hdr = $$ref = ''; bless { hdr => \$hdr, crlf => "\n" }, __PACKAGE__; @@ -85,8 +121,8 @@ sub new { sub new_sub { my (undef, $ref) = @_; # special case for messages like <85k5su9k59.fsf_-_@lola.goethe.zz> - $$ref =~ /\A(?:(\r?\n))/gs or goto &new; - my $hdr = substr($$ref, 0, pos($$ref), ''); # sv_chop on $$ref + $$ref =~ /\A(\r?\n)/s or goto &new; + my $hdr = substr($$ref, 0, $+[0], ''); # sv_chop on $$ref bless { hdr => \$hdr, crlf => $1, bdy => $ref }, __PACKAGE__; } @@ -108,23 +144,16 @@ sub header_raw { # pick the first Content-Type header to match Email::MIME behavior. # It's usually the right one based on historical archives. sub ct ($) { - # Email::MIME::ContentType::content_type: + # PublicInbox::EmlContentFoo::content_type: $_[0]->{ct} //= parse_content_type(header($_[0], 'Content-Type')); } -sub body_decode ($$) { - my $cte = header_raw($_[0], 'Content-Transfer-Encoding'); - ($cte) = ($cte =~ /([a-zA-Z0-9\-]+)/) if $cte; # For S/MIME, etc - (!$cte || $cte =~ $NO_ENCODE_RE) ? - $_[1] : Email::MIME::Encodings::decode($cte, $_[1], '7bit'); -} - # returns a queue of sub-parts iff it's worth descending into # TODO: descend into message/rfc822 parts (Email::MIME didn't) sub mp_descend ($$) { my ($self, $nr) = @_; # or $once for top-level my $bnd = ct($self)->{attributes}->{boundary} // return; # single-part - return if $bnd eq '' || length($bnd) >= $MAXBOUNDLEN; + return if $bnd eq '' || length($bnd) >= $mime_boundary_length_limit; $bnd = quotemeta($bnd); # "multipart" messages can exist w/o a body @@ -133,8 +162,12 @@ sub mp_descend ($$) { # Cut at the the first epilogue, not subsequent ones. # *sigh* just the regexp match alone seems to bump RSS by # length($$bdy) on a ~30M string: - $$bdy =~ /((?:\r?\n)?^--$bnd--[ \t]*\r?$)/gsm and - substr($$bdy, pos($$bdy) - length($1)) = ''; + my $epilogue_missing; + if ($$bdy =~ /(?:\r?\n)?^--$bnd--[ \t]*\r?$/sm) { + substr($$bdy, $-[0]) = ''; + } else { + $epilogue_missing = 1; + } # *Sigh* split() doesn't work in-place and return CoW strings # because Perl wants to "\0"-terminate strings. So split() @@ -148,10 +181,14 @@ sub mp_descend ($$) { # + 3 since we don't want the last part # processed to include any other excluded # parts ($nr starts at 1, and I suck at math) - $MAXPARTS + 3 - $nr); + $mime_parts_limit + 3 - $nr); if (@parts) { # the usual path if we got this far: undef $bdy; # release memory ASAP if $nr > 0 + + # compatibility with Email::MIME + $parts[-1] =~ s/\n\r?\n\z/\n/s if $epilogue_missing; + @parts = grep /[^ \t\r\n]/s, @parts; # ignore empty parts # Keep "From: someone..." from preamble in old, @@ -183,13 +220,15 @@ sub each_part { $p = [ $p, 0 ]; my @s; # our virtual stack my $nr = 0; - while ((scalar(@{$p->[0]}) || ($p = pop @s)) && ++$nr <= $MAXPARTS) { + while ((scalar(@{$p->[0]}) || ($p = pop @s)) && + ++$nr <= $mime_parts_limit) { ++$p->[-1]; # bump index my (undef, @idx) = @$p; @idx = (join('.', @idx)); my $depth = ($idx[0] =~ tr/././) + 1; my $sub = new_sub(undef, \(shift @{$p->[0]})); - if ($depth < $MAXDEPTH && (my $nxt = mp_descend($sub, $nr))) { + if ($depth < $mime_nesting_limit && + (my $nxt = mp_descend($sub, $nr))) { push(@s, $p) if scalar @{$p->[0]}; $p = [ $nxt, @idx, 0 ]; } else { # a leaf node @@ -198,6 +237,22 @@ sub each_part { } } +sub enc_qp { + # prevent MIME::QuotedPrint from encoding CR as =0D since it's + # against RFCs and breaks MUAs + $_[0] =~ s/\r\n/\n/sg; + encode_qp($_[0], "\r\n"); +} + +sub dec_qp { + # RFC 2822 requires all lines to end in CRLF, though... :< + $_[0] = decode_qp($_[0]); + $_[0] =~ s/\n/\r\n/sg; + $_[0] +} + +sub identity_codec { $_[0] } + ########### compatibility section for existing Email::MIME uses ######### sub header_obj { @@ -241,9 +296,9 @@ EOF sub body_set { my ($self, $body) = @_; my $bdy = $self->{bdy} = ref($body) ? $body : \$body; - my $cte = header_raw($self, 'Content-Transfer-Encoding'); - if ($cte && $cte !~ $NO_ENCODE_RE) { - $$bdy = Email::MIME::Encodings::encode($cte, $$bdy) + if (my $cte = header_raw($self, 'Content-Transfer-Encoding')) { + my $enc = $MIME_ENC{lc($cte)} or croak("can't encode `$cte'"); + $$bdy = $enc->($$bdy); # in-place } undef; } @@ -352,7 +407,13 @@ sub header_str { sub body_raw { ${$_[0]->{bdy} // \''}; } -sub body { body_decode($_[0], body_raw($_[0])) } +sub body { + my $raw = body_raw($_[0]); + my $cte = header_raw($_[0], 'Content-Transfer-Encoding') or return $raw; + ($cte) = ($cte =~ /([a-zA-Z0-9\-]+)/) or return $raw; # For S/MIME, etc + my $dec = $MIME_DEC{lc($cte)} or return $raw; + $dec->($raw); +} sub body_str { my ($self) = @_;