Perl 解析多部分/替代电子邮件

Question

我正在寻找一种方法来解析多部分/替代电子邮件的正文部分。我目前有一个使用 Email::Mime 模块的 perl 脚本，它可以正确解析 text/plain 和 text/html。虽然我遇到的问题是，当我解析多部分/替代电子邮件时， $part->body 总是返回空。我尝试过使用 $part->body_raw ，它确实返回文本正文，尽管它包含我需要省略的标题。

使用 $part->data_raw 的当前输出

--_000_47C8E15E8EEDCB4E94E891F9414C019A0CB5BDEE79DFW1MBX07mex0_
Content-Type: text/plain; charset="us-ascii"
Content-Transfer-Encoding: quoted-printable 

Text Body 

所需输出

Text Body

PERL代码

my ( $body, $text_body, $html_body, $multi_body );
for my $part (@parts) {

if ( $part->content_type =~ m!text/html! ) {
    my $hs = HTML::Strip->new( emit_spaces => 0 );
    $html_body .= $hs->parse( $part->body );
    print "Found HTML\n";
}
elsif ($part->content_type =~ m!text/plain!
    or $part->content_type eq '' )
{

    $text_body .= $part->body;
    print "Found TEXT\n";
}
elsif ($part->content_type =~ m!multipart/alternative!
    or $part->content_type eq '' )
{
    print "Found Multipart\n";
    $multi_body .= $part->body;     

}

来源

Content-Type: multipart/related;
boundary="_004_47C8E15E8EEDCB4E94E891F9414C019A0CB5BDEE79DFW1MBX07mex0_";
type="multipart/alternative"
MIME-Version: 1.0

--_004_47C8E15E8EEDCB4E94E891F9414C019A0CB5BDEE79DFW1MBX07mex0_
Content-Type: multipart/alternative;
boundary="_000_47C8E15E8EEDCB4E94E891F9414C019A0CB5BDEE79DFW1MBX07mex0_"

--_000_47C8E15E8EEDCB4E94E891F9414C019A0CB5BDEE79DFW1MBX07mex0_
Content-Type: text/plain; charset="us-ascii"
Content-Transfer-Encoding: quoted-printable

Test Body

Answer 1

多部分包含多个部分。迭代它们：

use strict;
use warnings;
use Email::MIME;
use Data::Printer;
use feature qw/say/;

my $source = <<EOF;
Content-Type: multipart/related;
boundary="_004_47C8E15E8EEDCB4E94E891F9414C019A0CB5BDEE79DFW1MBX07mex0_";
type="multipart/alternative"
MIME-Version: 1.0

--_004_47C8E15E8EEDCB4E94E891F9414C019A0CB5BDEE79DFW1MBX07mex0_
Content-Type: multipart/alternative;
boundary="_000_47C8E15E8EEDCB4E94E891F9414C019A0CB5BDEE79DFW1MBX07mex0_"

--_000_47C8E15E8EEDCB4E94E891F9414C019A0CB5BDEE79DFW1MBX07mex0_
Content-Type: text/plain; charset="us-ascii"
Content-Transfer-Encoding: quoted-printable

Test Body
EOF

my $msg = Email::MIME->new($source);

for my $part ($msg->parts) {
    if ($part->content_type =~ m!multipart/alternative!
            or $part->content_type eq '' )
        {
            say "Found Multipart"; 
            for my $subpart ($part->parts) {
                say $subpart->body;
            }
    }
}

输出：

C:\>perl test_mime.pl 
Found Multipart 
Test Body

Answer 2

您需要向下递归一级。

alternative

部分的“主体”是您需要检索和解析的

text/plain

部分。

一般来说，您不能假设任何特定的结构，只是

multipart

由一个或多个单独的部分组成（它们本身可以是

multiparts

递归地循环往复。），通常您会想要遍历它们。

虽然

multipart/alternative

非常清楚地记录了您应该选择其中一个成员部分（可能由您的平台功能和/或用户的偏好引导），但有时

multipart/mixed

或

multipart/related

会用于相同目的。

Answer 3

我喜欢接受的答案，但发现

Email::MIME

不是标准 Perl 安装的一部分——无论如何，在我们的站点上。

由于我需要与其他人共享我的脚本（具有不同程度的 Perl 暴露），因此我需要一个不涉及安装第三方模块的更简单的解决方案。

这里将显示标题 并 删除 MIME

text/html

电子邮件的

multipart/alternative

部分。

#!/usr/bin/env perl
use v5.12;
my ($boundary_marker, $current_boundary);
open my $fh, '<', $ARGV[0] or die "Requires one filename argument";

while (<$fh>) {
    if (/multipart\/alternative;/) {
        $_ = <$fh>;  # next line
        ($boundary_marker) = /.*boundary="(.*)"/;
        last;
    }
}

seek $fh, 0, 0;

while (<$fh>) {
    unless (/^(--$boundary_marker.*)/) {
        print;
        next;
    }

    $current_boundary = $1;
    $_ = <$fh>;  # next line
    
    if (/Content-Type: text\/html/) {
        while (<$fh>) {
            # skip over lines until boundary end
            last if /^--$boundary_marker/;
        }
    } else {
        print "$current_boundary\n$_";
    }
}

我did

diff

将生成的电子邮件与原始邮件进行比较，并验证Thunderbird也可以打开它，但这完全有可能需要更多的工作。希望它仍然是一个有用的例子：

我正在处理已经删除了 CR 的邮件文件，但请注意，直接从服务器发出的电子邮件可能会有 CR+LF 行结尾，因此您可能需要相应地调整最后一个

else

子句。