へぼい日記

知人にCPAN Authorになると宣言してから8年、やっとこさなりました。もちろんCPANにアップするだけなら誰だってできるので質の高いモジュールをアップできるように今後は心がけていきたいと思います。

で、初めてアップしたのがFormValidator::Nestedです。

これは、FormValidator::Simple、FormValidator::Lite、FormValidator::LazyWayなんかを参考に作られたFormValidatorです。

上記のモジュール達との主な違いといえる特長は、

• ネストしたパラメータを扱える
• 配列なパラメータを扱える
• profileを継承できる

あたりになるかと思います。

profileはとりあえず今はymlで書いて、そのファイルの置かれたbaseディレクトリを指定してそこからの相対PATHがkeyになるという感じです。(FormValidator::Nested::ProfileProviderの実装を増やすことでここは柔軟に対応可能な予定)

params:
  mail:
    name: メールアドレス
    validators:
      - Blank#not_blank
      - Email#email
      - String#max_length:
          max: 100

といった感じのprofileをhoge.ymlとかでprofileディレクトリに保存して

use FormValidator::Nested;
use Class::Param;

my $req = Class::Param->new({mail => 'hoge'});
my $fvt = FormValidator::Nested->new({
    profile_provider => FormValidator::Nested::ProfileProvider::YAML->new({
        dir => 'profile',
    }),
});
my $res = $fvt->validate($req, 'hoge');
if ( $res->has_error ) {
    my $error_param_ref = $res->error_params;
    while ( my ( $key, $error_params ) = %{$error_param_ref} ) {
        foreach my $error_param ( @{$error_params} ) {
            warn $error_param->key . ':' . $error_param->msg;
        }
    }
}

といったコードを実行すると、「mail:メールアドレスの形式が正しくありません」といったwarningが出力されるみたいな使い方ですね。

ネストしたパラメータを扱えるというのはどういうことかというと、

params:
  user:
    name: ユーザ
    nest: hoge

で、huga.ymlを作って(さきほどのhoge.ymlは残したまま)

use FormValidator::Nested;
use Class::Param;

my $req = Class::Param->new({ user => {mail => 'hoge'} });
my $fvt = FormValidator::Nested->new({
    profile_provider => FormValidator::Nested::ProfileProvider::YAML->new({
        dir => 'profile',
    }),
});
my $res = $fvt->validate($req, 'huga');
if ( $res->has_error ) {
    my $error_param_ref = $res->error_params;
    while ( my ( $key, $error_params ) = %{$error_param_ref} ) {
        foreach my $error_param ( @{$error_params} ) {
            warn $error_param->key . ':' . $error_param->msg;
        }
    }
}

とやると「user[mail]:メールアドレスの形式が正しくありません」みたいなwarningになります。ちなみにネストしたパラメータてのはCGI::Expandやそれを利用してるC::P::Params::Nestedなんかの利用を想定してます。Ajaxで動的なフォームを作ったりすると必要になる場面がありますよね。

さらに、配列なパラメータが扱えるというのは

params:
  mail:
    name: メールアドレス
    array: 1
    validators:
      - Blank#not_blank
      - Email#email
      - String#max_length:
          max: 100

とかでbaz.ymlを作っておいて

use FormValidator::Nested;
use Class::Param;

my $req = Class::Param->new({ mail => ['nihen@megabbs.com', 'hoge'] });
my $fvt = FormValidator::Nested->new({
    profile_provider => FormValidator::Nested::ProfileProvider::YAML->new({
        dir => 'profile',
    }),
});
my $res = $fvt->validate($req, 'baz');
if ( $res->has_error ) {
    my $error_param_ref = $res->error_params;
    while ( my ( $key, $error_params ) = %{$error_param_ref} ) {
        foreach my $error_param ( @{$error_params} ) {
            warn $error_param->key . ':' . $error_param->msg;
        }
    }
}

とやるとやはり「mail:メールアドレスの形式が正しくありません」となるという感じです。

あとは、継承ができるという件ですが

extends: hoge
params:
  name:
    name: 名前
    validators:
      - Blank#not_blank
      - String#max_length:
          max: 100

といったprofileを書くとhoge.ymlとHash::Mergeで結合されたprofileが使われるという感じです。Hash::MergeのbehaviorはFormValidator::Nested::ProfileProviderで指定しています。(あー$behaviorはourにしといたほうがいいかな。）

まぁ、こんなところです。ちとPODがぜんぜん書けていないのでこのエントリの内容も含めそのうちPODは書き足しておきます。それまではtディレクトリの中とかをあさってもらうとsampleになるものが一通りそろってるはずです。

あ、それとcodereposにもhttp://svn.coderepos.org/share/lang/perl/FormValidator-Nested/であげてあるのでパッチ等はこちらでいただけるとうれしいです。(まだgithubに移行してない奴)

あーあとfilterも同じymlでかける(ProfileProviderを共有できる)なんて機能もあります。

params:
  tel:
    filters:
      - String#remove_hyphen
      - String#alnum_z2h
    validators:
      - String#between_length:
          min: 10
          max: 11

ま、こんな感じ。

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のとこのエスケープ処理を修正

同じ場所のキャプチャに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自体のコメントも残っている可能性があります。これを除去する方法はまた別のお話。

Email::MIME::Kitがいい感じです。内部ではEmail::MIME::Creatorを使っているのですが、MIME::LiteでいうところのMIME::Lite::TTのようなもので、更にheaderに関してもtemplateで書けます。

素のEmail::MIME::Creatorで

use strict;
use warnings;
use utf8;

use Encode;
use Email::MIME;
use Email::MIME::Creator;
use Email::Send;
use Template;

my $t = Template->new({ENCODING => 'UTF-8'});
my $mydata = {hoge => 'aaa'};

$t->process('subject.tt', $mydata, \my $subject);
$t->process('body.tt', $mydata, \my $body);

my $mail = Email::MIME->create(
    header => [
        From    => 'chiba+from@geminium.com',
        To      => 'chiba+to@geminium.com',
        Subject => Encode::encode('MIME-Header', $subject),
    ],
    attributes => {
        content_type => 'text/plain',
        charset      => 'UTF-8',
    },
    body => $body,
);

my $sender = Email::Send->new({mailer => 'SMTP', mailer_args => [Host => 'localhost']});
$sender->send($mail);

って感じで書いてたものをEmail::MIME::Kitを使うと

use strict;
use warnings;
use utf8;

use Email::Send;
use Email::MIME::Kit;


my $sender = Email::Send->new({mailer => 'SMTP', mailer_args => [Host => 'localhost'] });

my $kit = Email::MIME::Kit->new({
    manifest_reader => 'YAML',
    source => 'mkit/',
});


$sender->send(
    $kit->assemble({
        hoge => 'fuga',
    })
);

という感じでシンプルに書けます。

mkit/manifest.yamlにはこんな感じで設定を書いておくと、body.ttが自動で読み込まれますし、headerの部分は外部ファイルにはできませんがTT書式で書けます。ここではrendererとしてTTを指定していますが、MicroMason、Text::TemplateあたりはCPANにアップされています。

renderer: TT
header:
  - Subject: 'てすと[% hoge %]'
  - From: 'Masahiro Chiba <chiba+from@geminium.com>'
  - To: 'Masahiro Chiba <chiba+to@geminium.com>'
attributes:
  content_type: text/plain
  charset: UTF-8
path: body.tt

マルチバイト文字コードはUTF-8のことしかほぼ考えられてないみたいなのでISO-2022-JPじゃないとだめだーって人は自分でEmail::MIME::Kit::Role::Assemblerの継承クラスを定義するといいと思います。Mooooseなモジュールなのでモダンに書けます。

で、標準のTTのrenderでちょっと不満だったのがprocessに渡されるのがテンプレートファイルの中身のリファレンスで、これだとTTがコンパイル結果をキャッシュしてくれないんですよね。ファイル名で渡しておくとキャッシュしてくれる。なのでpathが指定されている場合はrendererにpathをそのままスルーしてくれるAssemblerを書いてみました。

package Email::MIME::Kit::Assembler::PathThrough;
use Moose;
extends 'Email::MIME::Kit::Assembler::Standard';
with 'Email::MIME::Kit::Role::Assembler';
our $VERSION = '1.00';

use Template;

override '_assemble_from_kit' => sub {
    my ($self, $stash) = @_;

    my $fullpath = File::Spec->catfile($self->kit->source, $self->manifest->{path});
    my $body_ref = $self->render($fullpath, $stash);

    my %attr = %{ $self->manifest->{attributes} || {} };
    $attr{content_type} = $attr{content_type} || 'text/plain';

    if ($$body_ref =~ /[\x80-\xff]/) {
        $attr{encoding} ||= 'quoted-printable';
        $attr{charset}  ||= 'utf-8';
    }

    my $email = $self->_contain_attachments({
        attributes => \%attr,
        header     => $self->manifest->{header},
        stash      => $stash,
        body       => $$body_ref,
        container_type => $self->manifest->{container_type},
    });
};

after '_set_renderer' => sub {
    my $self = shift;
    $self->renderer->_tt(
        Template->new({
            ABSOLUTE => 1,
            ENCODING => 'UTF-8',
        }),
    );
};

no Moose;
1;

まぁやっぱりUTF-8前提だったりします。

manifestにはこんな感じで「assembler: PathThrough」を追加しておきます。

assembler: PathThrough
renderer: TT
header:
  - Subject: 'てすと[% hoge %]'
  - From: 'Masahiro Chiba <chiba+from@geminium.com>'
  - To: 'Masahiro Chiba <chiba+to@geminium.com>'
attributes:
  content_type: text/plain
  charset: UTF-8
path: body.tt

正規表現でHTML::FillInFormを実現しているHTML::FillInForm::Liteを最近つかっています。HTML::FillInFormの機能に加え、任意のオブジェクトを渡してそのアクセサからデータを取得してくれるため、DBIx::Class::AsFdatなどのモジュールを使わずに、DBICのrowデータをそのままfillinできるのがうれしかったりします。また、パラメータの取得方法部分もHTML::FillInFormよりも比較的拡張しやすくなっているので便利です。

ただ、性能がHTML::FillInFormよりもいいかというと自分の環境下やデータではそうでもなかったりして、特に大きいhtmlデータが対象だとかなり性能が劣化するようです。formのidをtargetで指定してあげることで大分緩和されますがHTML::FillInFromとの差は歴然としてあるようです。

そこで、C::P::FillInFormのようにhtml全体を対象とするのではなく、TTのフィルターを使ってfillinしてみました。

こんな感じでFILTERを定義して、

my $t = Template->new({
    ENCODING => 'UTF-8',
    FILTERS => {
        fillinform => [\&fillinform, 1],
    },
});
my $f = HTML::FillInForm::Lite->new;
sub fillinform {
    my ($context, $data, @options) = @_;

    return sub {
        my $html = shift;

        $f->fill(\$html, $data, @options);
    };
}

テンプレートの中ではこんな風に使います。

[% FILTER fillinform(filldata) %]<form>...</form>[% END %]

formの部分は別ファイルにしておくとこんなふうにシンプルにかけるのがいい感じです。

[% INCLUDE parts/form.tt | fillinform(filldata) %]

fillinformってのはCではなくてVの仕事なんじゃないかとも思うのでこちらのほうがわかりやすいような気もしてきてます。

で、最後にベンチマークをのっけておきます。全体のfillinと局所化したものがだいぶ差があるのがわかると思います。また、それでもHTML::FillInFormに勝てていませんが、大分差も縮まっています。

use strict;
use warnings;
use utf8;
binmode STDOUT, ':utf8';

use Benchmark qw/cmpthese/;
use Template;
use HTML::FillInForm;
use HTML::FillInForm::Lite;

my $t = Template->new({
    ENCODING => 'UTF-8',
    FILTERS => {
        fillinform => [\&fillinform, 1],
        fillinformlite => [\&fillinformlite, 1],
    },
});
my $f = HTML::FillInForm->new;
my $fl = HTML::FillInForm::Lite->new;
my $filldata = {mail => 'chiba@everqueue.com', name => '千葉征弘', tel => '03-3419-2801'};

cmpthese(5000, {
    fillinall => sub {
        $t->process('test.html', {
            hoge => 'aha'
        }, \my $output);

        $f->fill(\$output, $filldata);
    },
    fillinpart => sub {
        $t->process('test_part.html', {
            hoge => 'aha',
            filldata => $filldata,
        }, \my $output);
    },
    fillinall_lite => sub {
        $t->process('test.html', {
            hoge => 'aha'
        }, \my $output);

        $fl->fill(\$output, $filldata);
    },
    fillinpart_lite => sub {
        $t->process('test_part_lite.html', {
            hoge => 'aha',
            filldata => $filldata,
        }, \my $output);
    },
});
sub fillinform {
    my ($context, $data, @options) = @_;

    return sub {
        my $html = shift;

        $f->fill(\$html, $data, @options);
    };
}
sub fillinformlite {
    my ($context, $data, @options) = @_;

    return sub {
        my $html = shift;

        $fl->fill(\$html, $data, @options);
    };
}

test.html
test_part.html
test_part_lite.html

結果

                  Rate fillinall_lite     fillinall fillinpart_lite   fillinpart
fillinall_lite   274/s             --          -62%            -76%         -77%
fillinall        729/s           166%            --            -36%         -40%
fillinpart_lite 1136/s           315%           56%              --          -6%
fillinpart      1208/s           341%           66%              6%           --

catalystのstandaloneサーバを-r付きで使っている人はCatalyst::Develを1.16以上にUpgradeしたときは

catalyst.pl -force -scripts MyApp

を自分のmy appディレクトリで実行すること。しないと_kill_childメソッドが無いとかエラーがでます。

Exif情報確認君はじめりです。

今期、新たな試みとして社内でチームを2つつくってそれぞれサービスを1個づつ作ろう！とやってみた。が、日々の作業に忙殺されて結局作れないまま3月が終わろうとして、これは言いだしっぺとしてまずいと思い適当にExif情報確認君なるものをでっちあげてみた。

これはなに？

JPG画像をメールで送るとその画像に含まれるExif情報をメールで返送してくれるサービスです。さらにExif情報を削除した画像が添付されます。

Exif？

Exchangeable image file formatの略称。カメラの機種や撮影時の条件情報を画像に埋め込んだデータ(のフォーマット)。詳しくは
Exchangeable image file formatを。

そのた

もしかしてSPAMの踏み台になる恐れがあるかも。本当にそうなってきたら対策考える。

まぁそういうわけで、来期はもうすこしまともなサービスを作りたいです。尚、弊社ではプログラマを絶賛募集中です。興味のある方は募集要項をご覧になってjoin@geminium.comまでご連絡くださいです。Perlが好きな人大歓迎です。

use strict;

use Encode;
use Email::Address;
use Email::Valid;
use Email::Valid::Loose;
use Email::Find::addrspec;

my $wsp           = '[\x20\x09]';
my $vchar         = '[\x21-\x7e]';
my $quoted_pair   = "\\\\(?:$vchar|$wsp)";
my $qtext         = '[\x21\x23-\x5b\x5d-\x7e]';
my $qcontent      = "(?:$qtext|$quoted_pair)";
my $quoted_string = "\"$qcontent*\"";
my $atext         = '[a-zA-Z0-9!#$%&\'*+\-\/\=?^_`{|}~]';
my $dot_atom_text = "$atext+(?:[.]$atext+)*";
my $dot_atom      = $dot_atom_text;
my $local_part    = "(?:$dot_atom|$quoted_string)";
my $domain        = $dot_atom;
my $addr_spec     = qr{${local_part}[@]$domain};

my %addr_specs = (
    'mine' => $addr_spec,
    'Email::Address' => $Email::Address::addr_spec,
    'Email::Valid' => $Email::Valid::RFC822PAT,
    'Email::Valid::Loose' => $Email::Valid::Loose::Addr_spec_re,
    'Email::Find::addrspec' => $Email::Find::addrspec::Addr_spec_re,
);

use utf8;
my $input_addr_spec = 'hoge-hoge@example.com';
my $input_text = "ぼくの\@メールアドレスはbef\nore\x{7f}foo\@example.com\x{7f}afterです";
my $input_text_bytes = Encode::encode('utf-8', $input_text);


while ( my ( $package, $re ) = each %addr_specs ) {
    print "$package:\n";
    if ( $input_addr_spec =~ /\A$re\z/ ) {
        print " valid addr-spec\n";
    }
    else {
        print " invalid addr-spec\n";
    }

    print " flagged-utf8\n";
    if ( $input_text =~ /($re)/ms ) {
        print Encode::encode('utf-8', "  My addr-spec is <$1>\n");
    }
    else {
        print "  no-match\n";
    }

    print " bytes-utf8\n";
    if ( $input_text_bytes =~ /($re)/ms ) {
        print "  My addr-spec is <$1>\n";
    }
    else {
        print "  no-match\n";
    }
}

の結果が

Email::Find::addrspec:
 valid addr-spec
 flagged-utf8
  My addr-spec is <orefoo@example.com>
 bytes-utf8
  My addr-spec is <orefoo@example.com>
Email::Valid:
 valid addr-spec
 flagged-utf8
  My addr-spec is <ぼくの@メールアドレスはbef>
 bytes-utf8
  My addr-spec is <orefoo@example.comafter>
mine:
 valid addr-spec
 flagged-utf8
  My addr-spec is <foo@example.com>
 bytes-utf8
  My addr-spec is <foo@example.com>
Email::Valid::Loose:
 valid addr-spec
 flagged-utf8
  My addr-spec is <ぼくの@メールアドレスはbef>
 bytes-utf8
  My addr-spec is <orefoo@example.comafter>
Email::Address:
 valid addr-spec
 flagged-utf8
  My addr-spec is <ぼくの@メールアドレスはbef
>
 bytes-utf8
  My addr-spec is <ぼくの@メールアドレスはbef
>

になる件。近いうちにパッチ作って送るかも。

能書き

前エントリを書いてからいろいろと調べていて驚いたんだけど、日本語のwebsiteで、それなりにまともにRFC822(RFC2822,RFC5322)に準拠した(もしくはきちんと意図的に準拠していない部分を選択している)正規表現はPerlだろうがPHPだろうがRubyだろうが軽くぐぐった程度では見当たらない。PerlのモジュールのEmail::AddressもEmail::Validも程度の差はあれ問題を抱えている。そこらへんの既存の出回ってる正規表現にどういった問題があるかなんてことは次回エントリにて。

というわけで、Perl、PHP、RubyでRFC5322準拠なメールアドレス(addr-spec)の正規表現を以下に示します。尚、addr-specの最終的な正規表現のみならずそれを作成するに至る部分も併記してあります。これは、最終的な正規表現だけでは難解すぎてとても理解できないからです。内容を理解せずにそのままコピペすることを否定はしませんが理解しようとしたときの助けとなるよう、コメントアウトでもよいのでコード中に併記しておくことをお勧めします。

方針

• RFC5322準拠が基本
• addr_spec_looseは..や.@を許容した正規表現(日本のモバイルキャリア用)
• ただしobsoleteなsyntaxは無視
• ただしdomain_literalは無視
• ただしCFWSは無視
• ただしFWSも無視
• 上記のように無視してるのが多いのは用途をweb入力のチェックやテキストからの抜き出し用途を想定しているため
• BNFのsymbolの変数移植はできるだけRFCに即しつつ-を_に
• 文字種の記述はできるだけRFCの順番にあわせる
• ASCIIをコードポイントで指定する場合は16進数で
• perlではflagged utf8でも処理できるように
• できるだけテストはしてありますが、完璧だとは思っていないのでミスを指摘してくださる方は大歓迎です。

無視多すぎて準拠じゃないじゃんという突っ込みがありそうですが、自分で宣言している場合はありという俺ルールで。

Perl

動作確認: 5.10.0

my $wsp           = '[\x20\x09]';
my $vchar         = '[\x21-\x7e]';
my $quoted_pair   = "\\\\(?:$vchar|$wsp)";
my $qtext         = '[\x21\x23-\x5b\x5d-\x7e]';
my $qcontent      = "(?:$qtext|$quoted_pair)";
my $quoted_string = "\"$qcontent*\"";
my $atext         = '[a-zA-Z0-9!#$%&\'*+\-\/\=?^_`{|}~]';
my $dot_atom_text = "$atext+(?:[.]$atext+)*";
my $dot_atom      = $dot_atom_text;
my $local_part    = "(?:$dot_atom|$quoted_string)";
my $domain        = $dot_atom;
my $addr_spec     = qr{${local_part}[@]$domain};

my $dot_atom_loose   = "$atext+(?:[.]|$atext)*";
my $local_part_loose = "(?:$dot_atom_loose|$quoted_string)";
my $addr_spec_loose  = qr{${local_part_loose}[@]$domain};


my $input_addr_spec = 'foo@example.com';

if ( $input_addr_spec =~ /\A$addr_spec\z/ ) {
    print "valid addr-spec\n";
}

use utf8;
my $input_text = 'ぼくの@メールアドレスはfoo@example.comです';
if ( $input_text =~ /($addr_spec)/ ) {
    print "My addr-spec is <$1>\n";
}

PHP

動作確認: 5.2.6

<?php
$wsp           = '[\x20\x09]';
$vchar         = '[\x21-\x7e]';
$quoted_pair   = "\\\\(?:$vchar|$wsp)";
$qtext         = '[\x21\x23-\x5b\x5d-\x7e]';
$qcontent      = "(?:$qtext|$quoted_pair)";
$quoted_string = "\"$qcontent*\"";
$atext         = '[a-zA-Z0-9!#$%&\'*+\-\/\=?^_`{|}~]';
$dot_atom_text = "$atext+(?:[.]$atext+)*";
$dot_atom      = $dot_atom_text;
$local_part    = "(?:$dot_atom|$quoted_string)";
$domain        = $dot_atom;
$addr_spec     = "${local_part}[@]$domain";

$dot_atom_loose   = "$atext+(?:[.]|$atext)*";
$local_part_loose = "(?:$dot_atom_loose|$quoted_string)";
$addr_spec_loose  = "${local_part_loose}[@]$domain";


$input_addr_spec = 'foo@example.com';

if ( preg_match("/\A$addr_spec\z/", $input_addr_spec) ) {
    print "valid addr-spec\n";
}

$input_text = 'ぼくの@メールアドレスはfoo@example.comです';
if ( preg_match("/($addr_spec)/", $input_text, $matches) ) {
    print "My addr-spec is <$matches[0]>\n";
}

?>

Ruby

動作確認: 1.8.7

wsp           = '[\x20\x09]'
vchar         = '[\x21-\x7e]'
quoted_pair   = "\\\\(?:#{vchar}|#{wsp})"
qtext         = '[\x21\x23-\x5b\x5d-\x7e]'
qcontent      = "(?:#{qtext}|#{quoted_pair})"
quoted_string = "\"#{qcontent}*\""
atext         = '[a-zA-Z0-9!#$%&\'*+\-\/\=?^_`{|}~]'
dot_atom_text = "#{atext}+(?:[.]#{atext}+)*"
dot_atom      = dot_atom_text
local_part    = "(?:#{dot_atom}|#{quoted_string})"
domain        = dot_atom
addr_spec     = "#{local_part}[@]#{domain}"

dot_atom_loose   = "#{atext}+(?:[.]|#{atext})*"
local_part_loose = "(?:#{dot_atom_loose}|#{quoted_string})"
addr_spec_loose  = "#{local_part_loose}[@]#{domain}"

input_addr_spec = 'foo@example.com'

if /\A#{addr_spec}\z/ =~ input_addr_spec then
    puts "valid addr-spec"
end

input_text = 'ぼくの@メールアドレスはfoo@example.comです'
if /(#{addr_spec})/ =~ input_text then
    puts "My addr-spec is <#{$1}>";
end

テストコードこみのコード

以下にテストコード付きのものを貼り付けます。検証したいかたはどうぞ。テストケースは全言語共通になってます。

Perl

ファイル

#!/usr/bin/perl
use strict;
use Test::More;

my $wsp           = '[\x20\x09]';
my $vchar         = '[\x21-\x7e]';
my $quoted_pair   = "\\\\(?:$vchar|$wsp)";
my $qtext         = '[\x21\x23-\x5b\x5d-\x7e]';
my $qcontent      = "(?:$qtext|$quoted_pair)";
my $quoted_string = "\"$qcontent*\"";
my $atext         = '[a-zA-Z0-9!#$%&\'*+\-\/\=?^_`{|}~]';
my $dot_atom_text = "$atext+(?:[.]$atext+)*";
my $dot_atom      = $dot_atom_text;
my $local_part    = "(?:$dot_atom|$quoted_string)";
my $domain        = $dot_atom;
my $addr_spec     = qr{${local_part}[@]$domain};
print 'addr_spec: ' . $addr_spec, "\n";

my $dot_atom_loose   = "$atext+(?:[.]|$atext)*";
my $local_part_loose = "(?:$dot_atom_loose|$quoted_string)";
my $addr_spec_loose  = qr{${local_part_loose}[@]$domain};
print 'addr_spec_loose' . $addr_spec_loose, "\n";


my @valid = (
    'foo@example.com', # normal

    # local-part
     # dot-atom
     'foo.hoge@example.com',
     'foo.bar.baz@example.com',
     # quoted-string
     '"foo"@example.com',
     '"!"@example.com', # \x21
     '"#"@example.com', # \x23
     '"["@example.com', # \x5b
     '"]"@example.com', # \x5d
     '"["@example.com', # \x7e
      # quoted-pair
      '"\\ "@example.com', # \x20
      "\"\\\x09\"\@example.com", # \x09 # php @
      '"\\!"@example.com', # \x21
      '"\\["@example.com', # \x7e

    # domain
    'foo.hoge@localhost',
    'foo.hoge@sub.example.com',
);
my @valid_loose = (
    'foo.@docomo.ne.jp',
    'foo.foo.@docomo.ne.jp',
    'foo..@docomo.ne.jp',
    'foo..foo@docomo.ne.jp',
    'foo..foo.@docomo.ne.jp',
);

my @invalid = (
    '',
    'foo',
    'foo@',
    '@foo',
    # local-part
     # dot-atom
     '.foo@example.com',
     '..foo@example.com',
     'foo@@example.com',
     'foo[@example.com',
     'foo @example.com',
     # quoted-string
      "\"\x00\"\@example.com", # \x00 # php @
     '" "@example.com', # \x20
     '"""@example.com', # \x22
     '"\\"@example.com', # \x5c
      "\"\x7f\"\@example.com", # \x7f # php @
      # quoted-pair
      "\"\\\x1f\"\@example.com", # \x1f # php @
      "\"\\\x7f\"\@example.com", # \x7f # php @

    # \z check
    "foo\@example.com\n", # php @
    "foo\@example.com\nfoo\@example.com", # php @

    # non-ascii
    "\x80\@example.com",
    "\"\x80\"\@example.com",
    "\"\\\x80\"\@example.com",
    # utf8
    "\x100\@example.com",
    "\"\x100\"\@example.com",
    "\"\\\x100\"\@example.com",
);


plan tests => (@valid + @invalid + @valid_loose) * 2;

{
    # normal
    for (@valid) {
        ok( m{\A$addr_spec\z}o , 'normal-valid - ' . $_ );
    }

    for (@invalid, @valid_loose) {
        ok( !m{\A$addr_spec\z}o, 'normal-invalid - ' . $_ );
    }
}
{
    # loose
    for (@valid, @valid_loose) {
        ok( m{\A$addr_spec_loose\z}o , 'loose-valid - ' . $_ );
    }

    for (@invalid) {
        ok( !m{\A$addr_spec_loose\z}o, 'loose-invalid - ' . $_ );
    }
}

PHP

ファイル

<?php

$count = 0;

$wsp           = '[\x20\x09]';
$vchar         = '[\x21-\x7e]';
$quoted_pair   = "\\\\(?:$vchar|$wsp)";
$qtext         = '[\x21\x23-\x5b\x5d-\x7e]';
$qcontent      = "(?:$qtext|$quoted_pair)";
$quoted_string = "\"$qcontent*\"";
$atext         = '[a-zA-Z0-9!#$%&\'*+\-\/\=?^_`{|}~]';
$dot_atom_text = "$atext+(?:[.]$atext+)*";
$dot_atom      = $dot_atom_text;
$local_part    = "(?:$dot_atom|$quoted_string)";
$domain        = $dot_atom;
$addr_spec     = "${local_part}[@]$domain";
echo 'addr_spec: ' . $addr_spec, "\n";

$dot_atom_loose   = "$atext+(?:[.]|$atext)*";
$local_part_loose = "(?:$dot_atom_loose|$quoted_string)";
$addr_spec_loose  = "${local_part_loose}[@]$domain";
echo 'addr_spec_loose: ' . $addr_spec_loose, "\n";

$valid = array(
    'foo@example.com', # normal

    # local-part
     # dot-atom
     'foo.hoge@example.com',
     'foo.bar.baz@example.com',
     # quoted-string
     '"foo"@example.com',
     '"!"@example.com', # \x21
     '"#"@example.com', # \x23
     '"["@example.com', # \x5b
     '"]"@example.com', # \x5d
     '"["@example.com', # \x7e
      # quoted-pair
      '"foo\\ "@example.com', # \x20
      "\"foo\\\x09\"@example.com", # \x09 # php @
      '"\\!"@example.com', # \x21
      '"\\["@example.com', # \x7e

    # domain
    'foo.hoge@localhost',
    'foo.hoge@sub.example.com',
);
$valid_loose = array(
    'foo.@docomo.ne.jp',
    'foo.foo.@docomo.ne.jp',
    'foo..@docomo.ne.jp',
    'foo..foo@docomo.ne.jp',
    'foo..foo.@docomo.ne.jp',
);

$invalid = array(
    '',
    'foo',
    'foo@',
    '@foo',
    # local-part
     # dot-atom
     '.foo@example.com',
     '..foo@example.com',
     'foo@@example.com',
     'foo[@example.com',
     'foo @example.com',
     # quoted-string
      "\"\x00\"@example.com", # \x00 # php @
     '" "@example.com', # \x20
     '"""@example.com', # \x22
     '"\\"@example.com', # \x5c
      "\"\x7f\"@example.com", # \x7f # php @
      # quoted-pair
      "\"\\\x1f\"@example.com", # \x1f # php @
      "\"\\\x7f\"@example.com", # \x7f # php @

    # \z check
    "foo@example.com\n",
    "foo@example.com\nfoo@example.com",

    # non-ascii
    "\x80@example.com",
    "\"\x80\"@example.com",
    "\"\\\x80\"@example.com",
    # utf8
    "\x100@example.com",
    "\"\x100\"@example.com",
    "\"\\\x100\"@example.com",
);


{
    # normal
    foreach ($valid as $addr) {
        ok($addr_spec, $addr, 'normal-valid - ' . $addr);
    }

    foreach (array_merge($invalid, $valid_loose) as $addr) {
        not_ok($addr_spec, $addr, 'normal-invalid - ' . $addr);
    }
}
{
    # loose
    foreach (array_merge($valid, $valid_loose) as $addr) {
        ok($addr_spec_loose, $addr, 'loose-valid - ' . $addr);
    }

    foreach ($invalid as $addr) {
        not_ok($addr_spec_loose, $addr, 'loose-invalid - ' . $addr);
    }
}

function ok($regexp, $addr, $desc, $xor = 0) {
    global $count;
    $count++;
    if ( preg_match("/\A$regexp\z/", $addr) ^ $xor ) {
        echo "ok $count - $desc\n";
    }
    else {
        echo "not ok $count - $desc\n";
    }
}
function not_ok($regexp, $addr, $desc) {
    ok($regexp, $addr, $desc, 1);
}

?>

Ruby

ファイル

#!/usr/bin/ruby

wsp           = '[\x20\x09]'
vchar         = '[\x21-\x7e]'
quoted_pair   = "\\\\(?:#{vchar}|#{wsp})"
qtext         = '[\x21\x23-\x5b\x5d-\x7e]'
qcontent      = "(?:#{qtext}|#{quoted_pair})"
quoted_string = "\"#{qcontent}*\""
atext         = '[a-zA-Z0-9!#$%&\'*+\-\/\=?^_`{|}~]'
dot_atom_text = "#{atext}+(?:[.]#{atext}+)*"
dot_atom      = dot_atom_text
local_part    = "(?:#{dot_atom}|#{quoted_string})"
domain        = dot_atom
addr_spec     = "#{local_part}[@]#{domain}"
puts 'addr_spec: ' + addr_spec

dot_atom_loose   = "#{atext}+(?:[.]|#{atext})*"
local_part_loose = "(?:#{dot_atom_loose}|#{quoted_string})"
addr_spec_loose  = "#{local_part_loose}[@]#{domain}"
puts 'addr_spec_loose: ' + addr_spec_loose

valid = [
    'foo@example.com', # normal

    # local-part
     # dot-atom
     'foo.hoge@example.com',
     'foo.bar.baz@example.com',
     # quoted-string
     '"foo"@example.com',
     '"!"@example.com', # \x21
     '"#"@example.com', # \x23
     '"["@example.com', # \x5b
     '"]"@example.com', # \x5d
     '"["@example.com', # \x7e
      # quoted-pair
      '"foo\\ "@example.com', # \x20
      "\"foo\\\x09\"\@example.com", # \x09 # php @
      '"\\!"@example.com', # \x21
      '"\\["@example.com', # \x7e

    # domain
    'foo.hoge@localhost',
    'foo.hoge@sub.example.com',
]
valid_loose = [
    'foo.@docomo.ne.jp',
    'foo.foo.@docomo.ne.jp',
    'foo..@docomo.ne.jp',
    'foo..foo@docomo.ne.jp',
    'foo..foo.@docomo.ne.jp',
]

invalid = [
    '',
    'foo',
    'foo@',
    '@foo',
    # local-part
     # dot-atom
     '.foo@example.com',
     '..foo@example.com',
     'foo@@example.com',
     'foo[@example.com',
     'foo @example.com',
     # quoted-string
      "\"\x00\"\@example.com", # \x00 # php @
     '" "@example.com', # \x20
     '"""@example.com', # \x22
     '"\\"@example.com', # \x5c
      "\"\x7f\"\@example.com", # \x7f # php @
      # quoted-pair
      "\"\\\x1f\"\@example.com", # \x1f # php @
      "\"\\\x7f\"\@example.com", # \x7f # php @

    # \z check
    "foo@example.com\n",
    "foo@example.com\nfoo@example.com",

    # non-ascii
    "\x80\@example.com",
    "\"\x80\"\@example.com",
    "\"\\\x80\"\@example.com",
    # utf8
    "\x100\@example.com",
    "\"\x100\"\@example.com",
    "\"\\\x100\"\@example.com",
]


$count = 0
def ok(regexp, addr, desc, xor = 0)
    $count = $count + 1
    if  (/\A#{regexp}\z/ =~ addr) ^ xor then
        puts "ok #{$count} - #{desc}";
    else
        puts "not ok #{$count} - #{desc}";
    end
end

def not_ok(regexp, addr, desc)
    ok(regexp, addr, desc, 1)
end

# normal
valid.each do |addr|
    ok(addr_spec, addr, 'normal-valid - ' + addr);
end

(invalid + valid_loose).each do |addr|
    not_ok(addr_spec, addr, 'normal-invalid - ' + addr);
end

# loose
(valid + valid_loose).each do |addr|
    ok(addr_spec_loose, addr, 'loose-valid - ' + addr);
end

invalid.each do |addr|
    not_ok(addr_spec_loose, addr, 'loose-invalid - ' + addr);
end

(タイトルはid:hasegawayosukeさんが言ってたよ)

ああ、まただよ…

「PHP使いはもう正規表現をblogに書くな」と言わせないでくれ

正規表現って、プログラミング言語間の差が少ないサブ言語なのに、なぜ「DAN」がつくとダメ正規表現ばかり登場するのか。うんざりだ。

飽きたので以下略。

簡潔に。(正規表現はdanさんのものからシングルクォートコンテキストにあわせてエスケープをしてあります)

<?php
$email = 'test@example.com' . "\n";
$re = '/^(?:(?:(?:(?:[a-zA-Z0-9_!#\$\%&\'*+\/=?\^`{}~|\-]+)(?:\.(?:[a-zA-Z0-9_!#\$\%&\'*+\/=?\^`{}~|\-]+))*)|(?:"(?:\\\\[^\r\n]|[^\\\\"])*")))\@(?:(?:(?:(?:[a-zA-Z0-9_!#\$\%&\'*+\/=?\^`{}~|\-]+)(?:\.(?:[a-zA-Z0-9_!#\$\%&\'*+\/=?\^`{}~|\-]+))*)|(?:\[(?:\\\\\S|[\x21-\x5a\x5e-\x7e])*\])))$/';
if (preg_match($re,$email)) {
    echo "valid";
} else {
    echo "invalid";
}
?>

これの結果が「valid」になる。当然rfc5322でdot-atomには改行は(CRであれLFであれ)許されていない。

対策はdanさん自身が^$でなくて\A\zを使おうで述べているとおり。

<?php
$email = 'test@example.com' . "\n";
$re = '/\A(?:(?:(?:(?:[a-zA-Z0-9_!#\$\%&\'*+\/=?\^`{}~|\-]+)(?:\.(?:[a-zA-Z0-9_!#\$\%&\'*+\/=?\^`{}~|\-]+))*)|(?:"(?:\\\\[^\r\n]|[^\\\\"])*")))\@(?:(?:(?:(?:[a-zA-Z0-9_!#\$\%&\'*+\/=?\^`{}~|\-]+)(?:\.(?:[a-zA-Z0-9_!#\$\%&\'*+\/=?\^`{}~|\-]+))*)|(?:\[(?:\\\\\S|[\x21-\x5a\x5e-\x7e])*\])))\z/';
if (preg_match($re,$email)) {
    echo "valid";
} else {
    echo "invalid";
}
?>

ただしjavascriptではmフラグをつけない限りは$は改行直前にはマッチしないので問題なかったりもする。

ところでこの正規表現には他にも問題が残っている。domain-literalで\\\Sにマッチするようになっているがこれはなんなのだろう。

<?php
$email = 'test@[127.0.0.1' . "\\\x1f]";
$re = '/\A(?:(?:(?:(?:[a-zA-Z0-9_!#\$\%&\'*+\/=?\^`{}~|\-]+)(?:\.(?:[a-zA-Z0-9_!#\$\%&\'*+\/=?\^`{}~|\-]+))*)|(?:"(?:\\\\[^\r\n]|[^\\\\"])*")))\@(?:(?:(?:(?:[a-zA-Z0-9_!#\$\%&\'*+\/=?\^`{}~|\-]+)(?:\.(?:[a-zA-Z0-9_!#\$\%&\'*+\/=?\^`{}~|\-]+))*)|(?:\[(?:\\\\\S|[\x21-\x5a\x5e-\x7e])*\])))\z/';
if (preg_match($re,$email)) {
    echo "valid";
} else {
    echo "invalid";
}
?>

おかげで上記のコードもvalidだ。なんてこった。domain-literalなんてそもそもはずしてもいいような気もするけど、対応するとしたらこれでいんじゃないだろうか。

<?php
$email = 'test@[127.0.0.1' . "\\\x1f]";
$re = '/\A(?:(?:(?:(?:[a-zA-Z0-9_!#\$\%&\'*+\/=?\^`{}~|\-]+)(?:\.(?:[a-zA-Z0-9_!#\$\%&\'*+\/=?\^`{}~|\-]+))*)|(?:"(?:\\\\[^\r\n]|[^\\\\"])*")))\@(?:(?:(?:(?:[a-zA-Z0-9_!#\$\%&\'*+\/=?\^`{}~|\-]+)(?:\.(?:[a-zA-Z0-9_!#\$\%&\'*+\/=?\^`{}~|\-]+))*)|(?:\[[\x21-\x5a\x5e-\x7e]*\])))\z/';
if (preg_match($re,$email)) {
    echo "valid";
} else {
    echo "invalid";
}
?>

\\\Sになんか意味があるんだったらすみません。知ってる人いたら教えてください。

追記1(2009/03/20 01:57): コード例の(html)エスケープがおかしかったのを直しました。
追記2(2009/03/20 05:36): \\\Sに関してdanさんより404 Blog Not Found:regexp – ‘test@[127.0.0.1’ . "\\\x1f]" はRFC2822準拠で説明いただきました。ちなみにRFC5322にはquoted-pairはないかとおもってたら、obs-dtextの中にしっかり生き残ってた…。