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

Email::AddressParserを使うと、前エントリで問題にしてたdisplay-nameやcomment中にaddr-specみたいなのが現れるmailboxからの正しいaddr-specの抽出ができるみたいで、ちょっとやる気をなくしてたんですが一応足を突っ込んだ限りは修正しておこうということで、前エントリの問題の修正版。

複数のマッチが同一キャプチャにあるとどうしても駄目なのでmailboxの正規表現で複数回マッチさせる方針に変更。

mailboxの正規表現生成スクリプト

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{(?<obs_NO_WS_CTL>[\\x01-\\x08\\x0B\\x0C\\x0E-\\x1F\\x7F])};
my $obs_ctext = qq{(?&obs_NO_WS_CTL)};
my $obs_qtext = qq{(?&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{(?<FWS>(?:$WSP*$CRLF)?$WSP+|$obs_FWS)};
my $ctext = qq{(?<ctext>[\\x21-\\x27\\x2A-\\x5B\\x5D-\\x7E]|$obs_ctext)};
my $quoted_pair = qq{(?<quoted_pair>\\\\(?:$VCHAR|$WSP)|$obs_qp)};
my $ccontent = qq{(?:(?&ctext)|(?&quoted_pair)|(?&comment))};
my $comment = qq{(?<comment>\\((?:(?&FWS)?$ccontent)*(?&FWS)?\\))};
my $CFWS = qq{(?<CFWS>(?:(?&FWS)?(?&comment))+(?&FWS)?|(?&FWS))};

my $atext = qq{(?<atext>[A-Za-z0-9!#\$%&'*+\\-/=?^_`{|}~])};
my $atom = qq{(?<atom>(?&CFWS)?(?&atext)+(?&CFWS)?)};
my $dot_atom_text = qq{(?:(?&atext)+(?:\\.(?&atext)+)*)};
my $dot_atom = qq{(?<dot_atom>(?&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{(?<quoted_string>(?&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{(?<word>(?&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{(?<domain>(?&dot_atom)|$domain_literal|$obs_domain)};


# 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{(?<mailbox>$name_addr|$addr_spec)};

my @name_captures = qw/
    obs_NO_WS_CTL FWS ctext quoted_pair comment CFWS atext atom
    dot_atom quoted_string word domain mailbox
/;
my %tmp_name_captures = map { $_ => 1 } @name_captures;
my $last_count = keys %tmp_name_captures;
while ( keys %tmp_name_captures ) {
    foreach my $name_capture ( keys %tmp_name_captures ) {
        my $re = eval "\$$name_capture";
        $mailbox =~ s/(\(\?\&$name_capture\))/$re/;
        if ( $1 ) {
            delete $tmp_name_captures{$name_capture};
        }
    }
    last if $last_count == keys %tmp_name_captures;
    $last_count = keys %tmp_name_captures;
}

return qr/$mailbox/;
}

で、生成される正規表現が以下。全面的に名前付きキャプチャを使って書き直してあるので、正規表現自体も短くなってます。パフォーマンスも若干アップ。

(?<mailbox>(?:(?:(?<word>(?<atom>(?&CFWS)?(?&atext)+(?&CFWS)?)|(?&quoted_string))+|(?:(?&word)(?:(?&word)|\.|(?<CFWS>(?:(?<FWS>(?:[\x20\x09]*(?:\x0D\x0A))?[\x20\x09]+|(?:[\x20\x09]+(?:(?:\x0D\x0A)[\x20\x09]+)*))?(?<comment>\((?:(?&FWS)?(?:(?<ctext>[\x21-\x27\x2A-\x5B\x5D-\x7E]|(?&obs_NO_WS_CTL))|(?<quoted_pair>\\(?:[\x21-\x7E]|[\x20\x09])|(?:\\(?:\x00|(?&obs_NO_WS_CTL)|\x0A|\x0D)))|(?&comment)))*(?&FWS)?\)))+(?&FWS)?|(?&FWS)))*))?(?:(?&CFWS)?<(?<addr_spec>(?:(?<dot_atom>(?&CFWS)?(?:(?<atext>[A-Za-z0-9!#0&'*+\-/=?^_`{|}~])+(?:\.(?&atext)+)*)(?&CFWS)?)|(?<quoted_string>(?&CFWS)?"(?:(?&FWS)?(?:(?:[\x21\x23-\x5B\x5D-\x7E]|(?<obs_NO_WS_CTL>[\x01-\x08\x0B\x0C\x0E-\x1F\x7F]))|(?&quoted_pair)))*(?&FWS)?"(?&CFWS)?)|(?:(?&word)(?:\.(?&word))*))@(?<domain>(?&dot_atom)|(?:(?&CFWS)?\[(?:(?&FWS)?(?:[\x21-\x5A\x5E-\x7E]|(?:(?&obs_NO_WS_CTL)|(?&quoted_pair))))*(?&FWS)?\](?&CFWS)?)|(?:(?&atom)(?:\.(?&atom))*)))>(?&CFWS)?|(?:(?&CFWS)?<(?:(?:(?:(?&CFWS)|,)*@(?&domain)(?:,(?&CFWS)?@(?&domain))*):)(?<addr_spec>(?:(?&dot_atom)|(?&quoted_string)|(?:(?&word)(?:\.(?&word))*))@(?&domain))>(?&CFWS))))|(?<addr_spec>(?:(?&dot_atom)|(?&quoted_string)|(?:(?&word)(?:\.(?&word))*))@(?&domain)))

addr-specを取得する関数は、複数用と単数用でこんな感じ。From, ToはmultiをSenderはoneを使うといいと思います。

sub addr_specs_multi {
    my $input_from = shift;

    my @addr_specs = ();
    while ( $input_from =~ /$mailbox/go ) {
        foreach my $addr_spec ( @{$-{addr_spec}} ) {
            push @addr_specs, $addr_spec if defined($addr_spec);
        }
    }
    return \@addr_specs;
}
sub addr_specs_one {
    my $input_sendr = shift;

    if ( $input_sendr =~ /$mailbox/o ) {
        foreach my $addr_spec ( @{$-{addr_spec}} ) {
            return $addr_spec if defined($addr_spec);
        }
    }
    else {
        return;
    }
}

まーしかし、Email::AddressParser使えばいいと思いますです。正規表現ではなくXSで字句解析を行っているようで速度も断然早いです。また、コメントの削除も行ってくれます。
webチェックや汎用テキストからの抽出は以前のエントリの正規表現でmailboxを対象としたaddr-specの抜き出しはEmail::AddressParserを使うという使い分けがベストかと思われます。

2009/08/10 15:32 $atextのとこのエスケープ処理を修正