メールヘッダからaddr-specを抜き出す正規表現

同じ場所のキャプチャに2回以上マッチした場合に最後にマッチしたものしかとれない問題があった(‘From: <hoge@example.com>,<hoge2@example.com>,<hoge3@example.com>’とか)のでちと、現在修正を考え中。なかなか難しいなぁ。

以前、メールアドレス(addr-spec)の正規表現をポストしたのですが、あれはweb入力のチェックや汎用的なテキストからの抜き出しを前提としており、メールヘッダからのaddr-specの抽出には向いていません。

例えば、「From: "hoge@example.com" <foo@example.com>」
というFromヘッダに対して前述の正規表現を適用すると「hoge@example.com」が抽出されてしまい、
これは正しいaddr-specではありません。正しいaddr-specは「foo@example.com」になるからです。

そこで、From Sender Toの各ヘッダ対象の正規表現を作成し、そこからaddr-specを抜き出す正規表現と関数を作成しました。以下に示します。

my $CR = qq{\\x0D};
my $LF = qq{\\x0A};
my $CRLF = qq{(?:\\x0D\\x0A)};
my $VCHAR = qq{[\\x21-\\x7E]};
my $WSP = qq{[\\x20\\x09]};

my $obs_NO_WS_CTL = qq{[\\x01-\\x08\\x0B\\x0C\\x0E-\\x1F\\x7F]};
my $obs_ctext = $obs_NO_WS_CTL;
my $obs_qtext = $obs_NO_WS_CTL;
my $obs_qp = qq{(?:\\\\(?:\\x00|$obs_NO_WS_CTL|$LF|$CR))};
my $obs_FWS = qq{(?:$WSP+(?:$CRLF$WSP+)*)};

my $FWS = qq{(?:(?:$WSP*$CRLF)?$WSP+|$obs_FWS)};
my $ctext = qq{(?:[\\x21-\\x27\\x2A-\\x5B\\x5D-\\x7E]|$obs_ctext)};
my $quoted_pair = qq{(?:\\\\(?:$VCHAR|$WSP)|$obs_qp)};
my $ccontent = qq{(?:$ctext|$quoted_pair|(?-1))};
my $comment = qq{(\\((?:$FWS?$ccontent)*$FWS?\\))};
my $CFWS = qq{(?:(?:$FWS?$comment)+$FWS?|$FWS)};

my $atext = qq{[A-Za-z0-9!#$%&'*+\\-/=?^_`{|}~]};
my $atom = qq{(?:$CFWS?$atext+$CFWS?)};
my $dot_atom_text = qq{(?:$atext+(?:\\.$atext+)*)};
my $dot_atom = qq{(?:$CFWS?$dot_atom_text$CFWS?)};

my $qtext = qq{(?:[\\x21\\x23-\\x5B\\x5D-\\x7E]|$obs_qtext)};
my $qcontent = qq{(?:$qtext|$quoted_pair)};
my $quoted_string = qq{(?:$CFWS?"(?:$FWS?$qcontent)*$FWS?"$CFWS?)};

my $obs_dtext = qq{(?:$obs_NO_WS_CTL|$quoted_pair)};
my $dtext = qq{(?:[\\x21-\\x5A\\x5E-\\x7E]|$obs_dtext)};
my $domain_literal = qq{(?:$CFWS?\\[(?:$FWS?$dtext)*$FWS?\\]$CFWS?)};

my $word = qq{(?:$atom|$quoted_string)};
my $obs_local_part = qq{(?:$word(?:\\.$word)*)};
my $obs_domain = qq{(?:$atom(?:\\.$atom)*)};
my $local_part = qq{(?:$dot_atom|$quoted_string|$obs_local_part)};
my $domain = qq{(?:$dot_atom|$domain_literal|$obs_domain)};

# ここまで大崎さんのhttp://www.din.or.jp/~ohzaki/mail_regex.htm#RFCを参照

# addr_specを名前付きキャプチャ化
my $addr_spec = qq{(?<addr_spec>$local_part\@$domain)};


my $obs_phrase = qq{(?:$word(?:$word|\\.|$CFWS)*)};
my $phrase = qq{(?:$word+|$obs_phrase)};
my $display_name = $phrase;

my $obs_domain_list = qq{(?:(?:$CFWS|,)*\@$domain(?:,$CFWS?\@$domain)*)};
my $obs_route = qq{(?:$obs_domain_list:)};
my $obs_angle_addr = qq{(?:$CFWS?<$obs_route$addr_spec>$CFWS)};
my $angle_addr = qq{(?:$CFWS?<$addr_spec>$CFWS?|$obs_angle_addr)};
my $name_addr = qq{(?:$display_name?$angle_addr)};
my $mailbox = qq{(?:$name_addr|$addr_spec)};

my $obs_mbox_list = qq{(?:(?:$CFWS?,)*$mailbox(?:,(?:$mailbox|$CFWS)?)*)};

my $mailbox_list = qq{(?:$mailbox(?:,$mailbox)*|$obs_mbox_list)};

my $obs_group_list = qq{(?:(?:$CFWS?,)+$CFWS?)};
my $group_list = qq{(?:$mailbox_list|$CFWS|$obs_group_list)};
my $group = qq{(?:$display_name:$group_list?;$CFWS?)};
my $address = qq{(?:$mailbox|$group)};
my $obs_addr_list = qq{(?:(?:$CFWS?,)*$address(?:,(?:$CFWS|$address)?)*)};
my $address_list = qq{(?:$address(?:,$address)|$obs_addr_list)};

my $from = qq{From:$mailbox_list(?:$CR$LF)?};
my $sender = qq{Sender:$mailbox(?:$CR$LF)?};
my $to = qq{To:$address_list(?:$CR$LF)?};

sub addr_specs_from_from {
    my $input_from = shift;

    if ( $input_from =~ /\A$from\z/ ) {
        my @addr_specs = ();
        foreach my $addr_spec ( @{$-{addr_spec}} ) {
            push @addr_specs, $addr_spec if defined($addr_spec);
        }
        return \@addr_specs;
    }
    else {
        return;
    }
}
sub addr_specs_from_sender {
    my $input_sendr = shift;

    if ( $input_sendr =~ /\A$sender\z/ ) {
        foreach my $addr_spec ( @{$-{addr_spec}} ) {
            return $addr_spec if defined($addr_spec);
        }
    }
    else {
        return;
    }
}
sub addr_specs_from_to {
    my $input_to = shift;

    if ( $input_to =~ /\A$to\z/ ) {
        my @addr_specs = ();
        foreach my $addr_spec ( @{$-{addr_spec}} ) {
            push @addr_specs, $addr_spec if defined($addr_spec);
        }
        return \@addr_specs;
    }
    else {
        return;
    }
}

今回は対象がメールのヘッダなので、コメントやobsoleteなsyntaxについてもRFC完全準拠になっています。

確認は下記ようになコードで可能です。

use Data::Dumper;
print Dumper addr_specs_from_from('From: "hoge@example.com" (aaa (hoge) ) <foo@example.com>, <foo2@example.com>,foo3@example.com');
print Dumper addr_specs_from_sender('Sender: "hoge@example.com" (aaa (hoge) ) <foo@example.com>');
print Dumper addr_specs_from_to('To: "hoge@example.com" (aaa (hoge) ) <foo1@example.com>, <foo2@example.com>');

の結果は

$VAR1 = [
          'foo@example.com',
          'foo2@example.com',
          'foo3@example.com'
        ];
$VAR1 = 'foo@example.com';
$VAR1 = [
          'foo1@example.com',
          'foo2@example.com'
        ];

となります。

尚、Fromヘッダに複数のmailboxが指定されている場合には、Senderヘッダに単一のmailboxを指定することが必須(MUST)とされています(RFC5322 3.6.2)ので、addr_specs_from_fromから複数のaddr-specが帰ってきた場合はにaddr_specs_from_senderにSenderヘッダを渡すという利用がベストと思われます。

最後に、大崎さんに習って最終的な正規表現を晒そうかと思ったのですがFromのものが269,514バイトとかいうアホみたいな容量になったのでやめておきます。冗長なクラスタ化を避ければもうちょい短くはなるんでしょうが・・・。ひどいですね。ちなみにToヘッダはもっとひどくと1,394,979バイトです。1Mbyte突破してますｗ当然パフォーマンスも酷いもんです。実用にほぼ耐えません。名前付きキャプチャを全面的に使って書きなおすと正規表現自体は短くなりそうですがパフォーマンスはどうなんでしょうかね。うーむ。

尚、抽出できたaddr-specにはまだaddr-spec自体のコメントも残っている可能性があります。これを除去する方法はまた別のお話。